├── LICENSE ├── README.md ├── docs ├── .nojekyll ├── Examples │ ├── CountInstances.md │ └── ExportData.md ├── ObjectReference │ ├── Methods │ │ ├── Add.md │ │ ├── AddBulk.md │ │ ├── GetData.md │ │ └── GetValue.md │ └── Properties │ │ ├── DataCols.md │ │ ├── DataRows.md │ │ └── OptionNoItemFail.md ├── README.md ├── _404.md ├── _sidebar.md └── index.html ├── src └── Dictionary.cls └── test ├── DictionaryTests.bas └── TestResult.cls /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 Sam Vanderslink 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA-ExtendedDictionary 2 | Dictionary object that extends the Scripting.Dictionary 3 | 4 | [![MIT license](https://img.shields.io/badge/License-MIT-blue.svg)](https://github.com/SSlinky/VBA-ExtendedDictionary/blob/master/README.md#license) 5 | [![VBA](https://img.shields.io/badge/vba-VB--6-success)](https://docs.microsoft.com/en-us/office/vba/api/overview/) 6 | [![Buy me a Beer!](https://img.shields.io/badge/Buy%20me%20a-Beer-yellow)](https://www.buymeacoffee.com/sslinky) 7 | 8 | ExtendedDictionary exposes the standard functionality of a [Scripting.Dictionary object](https://learn.microsoft.com/en-au/office/vba/language/reference/user-interface-help/dictionary-object) as well as providing additional useful functionality that avoids boilerplate. 9 | 10 | * Load range of values as key / value pairs for fast dictionary population. 11 | * Better control over what does and does not raise an error. 12 | * Option to count the keys rather than load values. 13 | * Wrapper to get value or default similar to modern languages. 14 | 15 | ## Installation 16 | Download the Dictionary.cls file and add it to your project. 17 | 18 | ## Documentation 19 | [Read the docs](https://sslinky.github.io/VBA-ExtendedDictionary/#/) for usage and examples. 20 | 21 | ## Licence 22 | Released under [MIT](/LICENCE) by [Sam Vanderslink](https://github.com/SSlinky). 23 | Free to modify and reuse. 24 | -------------------------------------------------------------------------------- /docs/.nojekyll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SSlinky/VBA-ExtendedDictionary/2a9627af1d85aacc55200f9251884a4e932bfe9c/docs/.nojekyll -------------------------------------------------------------------------------- /docs/Examples/CountInstances.md: -------------------------------------------------------------------------------- 1 | # Counting value occurrences 2 | 3 | Based on [this question](https://www.reddit.com/r/vba/comments/lp5vxz/vba_code_to_count_for_certain_instances_of_text/) asked on Reddit. 4 | 5 | ## Problem statement 6 | 7 | Data exists in column A. Occurrences of the words "INAUDIBLE" and "NO RESPONSE" must be counted if the cell is not hidden. 8 | 9 | ## Solution 10 | 11 | ExtendedDictionary (ed) makes this trivial. 12 | 13 | 1. Declare variablesa and define the data range. 14 | 2. Add the data to ed using the `AddBulk` method with `OptionCountKeys` enabled. 15 | 3. Use the `GetValue` method to safely retrieve a value, or return the deafult 0 if it doesn't exist. 16 | 17 | ```vba 18 | Option Explicit 19 | 20 | Sub CountInstances() 21 | Dim ed As New Dictionary 22 | 23 | ' Arrange the visible data into an array 24 | Dim rg As Range 25 | Set rg = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row) 26 | 27 | ' Each contiguous batch of cells must be iterated through 28 | ' since .SpecialCells returns a union and .Value gets the 29 | ' values from the first range in the union only. 30 | Dim r As Range 31 | For Each r In rg.SpecialCells(xlCellTypeVisible, True).Areas 32 | ' Add the visible cells to the dictionary, counting the keys. 33 | ed.AddBulk r.Value, OptionCountKeys:=True 34 | Next r 35 | 36 | ' Print the count values to the immediate window. 37 | Dim k As Variant 38 | For Each k In Array("INAUDIBLE", "NO RESPONSE") 39 | Debug.Print k & ":", ed.GetValue(k, 0) 40 | Next 41 | 42 | End Sub 43 | ``` 44 | -------------------------------------------------------------------------------- /docs/Examples/ExportData.md: -------------------------------------------------------------------------------- 1 | # Export Data to Range 2 | 3 | Exporting the data is nearly as simple as importing it with `AddBulk`. 4 | 5 | Using the `DataRows` and `DataCols` properties, we can resize a range so we can set the values to the output of `GetData`. 6 | 7 | ```vba 8 | Sub ExportExample(ed As Dictionary, dst As Range) 9 | dst.Resize(ed.DataRows, ed.DataCols).Value = ed.GetData 10 | End Sub 11 | ``` 12 | -------------------------------------------------------------------------------- /docs/ObjectReference/Methods/Add.md: -------------------------------------------------------------------------------- 1 | # Add method 2 | 3 | Adds a key and item pair to the Scripting.Dictionary 4 | 5 | ## Syntax 6 | 7 | _object_.**Add** _Key_, _Val_ 8 | 9 | The **Add** method has the following parts: 10 | 11 | Part | Description 12 | :--- | :--- 13 | _object_ | Required. Always the name of a **Dictionary** object. 14 | _Key_ | Required. They key associated with the item being added. 15 | _[Val]_ | Optional. The value associated with the key being added. 16 | 17 | ## Remarks 18 | 19 | If `OptionNoItemFail` is `False` then an error will be raised if the key already exists. 20 | 21 | If the option is set to `True` then adding a key will not fail, it will override the previous value. This can be useful to avoid boilerplate checking for duplicates. 22 | -------------------------------------------------------------------------------- /docs/ObjectReference/Methods/AddBulk.md: -------------------------------------------------------------------------------- 1 | # AddBulk method 2 | 3 | Adds key value pairs from a 2D array. Supports keys as first row or first column. Automatically detects array size and adds values based on number of values per key. 4 | 5 | ## Syntax 6 | 7 | _object_.**AddBulk** _ValueArray2D_, _[OptionUseRowMode]_, _[OptionCountKeys]_ 8 | 9 | The **AddBulk** method has the following parts: 10 | 11 | Part | Description 12 | :--- | :--- 13 | _object_ | Required. Always the name of a **Dictionary** object. 14 | _ValueArray2D_ | Required. A two dimensional array of at least one row and column. 15 | _[OptionUseRowMode]_ | Optional. Use the first row instead of the first column as keys. 16 | _[OptionCountKeys]_ | Optional. The value is the number of times the key has been found. This will force `OptionNoItemFail` to True. 17 | 18 | ## Examples 19 | 20 | ### Key only 21 | 22 | Load a simple 2D array with only one column. The values will be defaulted to Nothing. 23 | 24 | ```vba 25 | Dim ed As New Dictionary 26 | ed.AddBulk Range("A1:A50").Value 27 | ``` 28 | 29 | ### Key / single value pairs 30 | 31 | Load a simple 2D array where the first column is the key and the second column is the value. 32 | 33 | ```vba 34 | Dim ed As New Dictionary 35 | ed.AddBulk Range("A1:B50").Value 36 | ``` 37 | 38 | ### Horizontal key / multiple value pairs 39 | 40 | Load a 2D array with a key and more than one value. Using `OptionUseRowMode` we can specify that the keys are in the first row of the 41 | array rather than the default first column behaviour. 42 | 43 | ```vba 44 | Dim ed As New Dictionary 45 | ed.AddBulk Range("A1:Z5").Value, OptionUseRowMode=True 46 | ``` 47 | 48 | ### Count unique values 49 | 50 | Load simple 2D array. Only the first row or column will be considered, depending on `OptionUseRowMode`. The values will be the count of times the key 51 | appears in the passed in array. 52 | 53 | ```vba 54 | Dim ed As New Dictionary 55 | ed.AddBulk Range("A1:A500").Value, OptionCountKeys=True 56 | ``` 57 | 58 | The use of `OptionCountKeys` implies [OptionNoItemFail](./ObjectReference/Properties/OptionNoItemFail.md). Using this option will override the property to `True`. 59 | -------------------------------------------------------------------------------- /docs/ObjectReference/Methods/GetData.md: -------------------------------------------------------------------------------- 1 | # GetData method 2 | 3 | Generates a Variant array with the key / value pairs in the Scripting.Dictionary. 4 | 5 | ## Syntax 6 | 7 | _object_.**GetData** (_[OptionUseRowMode]_) 8 | 9 | The **GetData** method has the following parts: 10 | 11 | Part | Description 12 | :--- | :--- 13 | _object_ | Required. Always the name of a **Dictionary** object. 14 | _OptionUseRowMode_ | Optional. Orients keys and values vertically or horizontally. 15 | 16 | ## Remarks 17 | 18 | This function returns a base 1 2D array of type variant. This means it is already in an appropriate format to insert into a range. 19 | 20 | The shape of the array will depend on the data. They keys will define the size of the first or second dimension, depending on whether `OptionUseRowMode` is True or not. The values will populate the other dimension if they exist. 21 | 22 | Note that if no data exists in the dictionary, the returned array will be a single cell with Nothing. 23 | 24 | ## Examples 25 | 26 | ### Using OptionUserRowMode 27 | 28 | `OptionUseRowMode:=True` keys are arranged across columns in the first row. Values populate rows below their respective key. 29 | 30 | | k1 | k2 | k3 | 31 | | --- | --- | --- | 32 | | v1a | v2a | v3a | 33 | | v1b | v2b | v3b | 34 | | v1c | v2c | v3c | 35 | 36 | `OptionUseRowMode:=False` keys are arranged across rows in the first column. Values populate columns right of their respective key. 37 | 38 | | | | | | 39 | | --- | --- | --- | --- | 40 | | **k1** | v1a | v1b | v1c | 41 | | **k2** | v2a | v2b | v2c | 42 | | **k3** | v3a | v3b | v3c | 43 | 44 | ### Returned Array Sizes 45 | 46 | Array sizes returned by data type. Assumes `OptionUseRowMode` is `False`. Note that in these cases, the first column is the key so 47 | the values start from the second column. 48 | 49 | Keys | Values per Key | Return Shape (D1, D2) 50 | --- | --- | :--- 51 | 0 | 0 | (1 to 1, 1 to 1) 52 | 10 | 0 | (1 to 10, 1 to 1) 53 | 16 | 255 | (1 to 16, 1 to 256) 54 | -------------------------------------------------------------------------------- /docs/ObjectReference/Methods/GetValue.md: -------------------------------------------------------------------------------- 1 | # GetValue method 2 | 3 | Wrapper property that returns the value for the specified key if it exists. 4 | If it doesn't exist, it returns the default rather than raise an error. 5 | 6 | ## Syntax 7 | 8 | _object_.**GetValue** _Key_, _ItemDefault_ 9 | 10 | The **GetValue** method has the following parts: 11 | 12 | Part | Description 13 | :--- | :--- 14 | _object_ | Required. Always the name of a **Dictionary** object. 15 | _Key_ | Required. They key associated with the value being looked up. 16 | _ItemDefault_ | Required. The default value to be returned if the key is not found. 17 | 18 | ## Remarks 19 | 20 | This method has been added to provide an equivalent getter to those found in other modern languages. 21 | 22 | ## Examples 23 | 24 | ### Key value counts 25 | 26 | ```vba 27 | Dim cityCounter As New Dictionary 28 | cityCounter.AddBulk Range("A1:A500").Value, OptionCountKeys=True 29 | 30 | ' Assume the key Perth appeared in the data 5 times but Melbourne 31 | ' didn't appear at all. Attempting to get the count for Melbourne 32 | ' would result in an error but the desired result is 0. 33 | 34 | Debug.Print "Perth: " & cityCounter.GetValue("Perth", 0) ' Perth: 5 35 | Debug.Print "Melbourne: " & cityCounter.GetValue("Melbourne", 0) ' Melbourne: 0 36 | ``` 37 | -------------------------------------------------------------------------------- /docs/ObjectReference/Properties/DataCols.md: -------------------------------------------------------------------------------- 1 | # DataCols Property 2 | 3 | Returns the count of columns `GetData` would return. 4 | 5 | ## Syntax 6 | 7 | _object_.**DataCols** (_[OptionUseRowMode]_) 8 | 9 | Part | Description 10 | :--- | :--- 11 | _object_ | Required. Always the name of a **Dictionary** object. 12 | _OptionUseRowMode_ | Optional. Whether to run in row mode or not. 13 | 14 | ## Remarks 15 | 16 | This property is most useful when using `GetData` to write to a range. 17 | 18 | The mode determines the shape of your data. If in column mode, with keys running down a column, this property returns the length of your data. Otherwise it returns the count of the keys. 19 | 20 | `ed.DataCols` is equivalent to `ed.DataRows OptionUseRowMode:=True` 21 | -------------------------------------------------------------------------------- /docs/ObjectReference/Properties/DataRows.md: -------------------------------------------------------------------------------- 1 | # DataRows Property 2 | 3 | Returns the count of rows `GetData` would return. 4 | 5 | ## Syntax 6 | 7 | _object_.**DataRows** (_[OptionUseRowMode]_) 8 | 9 | Part | Description 10 | :--- | :--- 11 | _object_ | Required. Always the name of a **Dictionary** object. 12 | _OptionUseRowMode_ | Optional. Whether to run in row mode or not. 13 | 14 | ## Remarks 15 | 16 | This property is most useful when using `GetData` to write to a range. 17 | 18 | The mode determines the shape of your data. If in column mode, with keys running down a column, this property returns the count of the keys. Otherwise it returns the length of your data. 19 | 20 | `ed.DataRows` is equivalent to `ed.DataCols OptionUseRowMode:=True` 21 | -------------------------------------------------------------------------------- /docs/ObjectReference/Properties/OptionNoItemFail.md: -------------------------------------------------------------------------------- 1 | # OptionNoItemFail Property 2 | 3 | Returns or sets a Boolean that configures the object to raise or ignore errors when getting or setting dictionary items. 4 | 5 | ## Syntax 6 | 7 | _object_.**OptionNoItemFail** 8 | 9 | Value | Action | Behaviour 10 | ------|--------|---------- 11 | False | Add item that exists | Exception is raised. 12 | False | Get item that doesn't exist | Exception is raised. 13 | True | Add item that exists | The value for that key is updated. 14 | True | Get item that doesn't exist | Nothing is returned and no exception is raised. 15 | 16 | ## Remarks 17 | 18 | This option allows safe getting and setting without having to write boilerplate to test whether the key exists or not. 19 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # VBA-ExtendedDictionary 2 | Dictionary object that extends the Scripting.Dictionary 3 | 4 | [![MIT license](https://img.shields.io/badge/License-MIT-blue.svg)](https://github.com/SSlinky/VBA-ExtendedDictionary/blob/master/README.md#license) 5 | [![VBA](https://img.shields.io/badge/vba-VB--6-success)](https://docs.microsoft.com/en-us/office/vba/api/overview/) 6 | 7 | 8 | ExtendedDictionary exposes the standard functionality of a [Scripting.Dictionary object](https://docs.microsoft.com/en-au/office/vba/language/reference/user-interface-help/dictionary-object) as well as providing additional useful functionality that avoids boilerplate. 9 | 10 | * Load range of values as key / value pairs for fast dictionary population. 11 | * Better control over what does and does not raise an error. 12 | * Option to count the keys rather than load values. 13 | * Wrapper to get value or default similar to modern languages. 14 | 15 | 16 | For standard Scripting.Dictionary functionality, see the [object documentation](https://docs.microsoft.com/en-au/office/vba/language/reference/user-interface-help/dictionary-object) provided by Microsoft. -------------------------------------------------------------------------------- /docs/_404.md: -------------------------------------------------------------------------------- 1 | # 404 2 | 3 | ## File not found 4 | 5 | Oops! The site configured at this address does not contain the requested file. -------------------------------------------------------------------------------- /docs/_sidebar.md: -------------------------------------------------------------------------------- 1 | - [Home](/ "VBA-ExtendedDictionary") 2 | - Object Reference 3 | 4 | - Methods 5 | - [Add](ObjectReference/Methods/Add.md "VBA-ExtendedDictionary - Methods - Add") 6 | - [AddBulk](ObjectReference/Methods/AddBulk.md "VBA-ExtendedDictionary - Methods - AddBulk") 7 | - [GetData](ObjectReference/Methods/GetData.md "VBA-ExtendedDictionary - Methods - GetData") 8 | - [GetValue](ObjectReference/Methods/GetValue.md "VBA-ExtendedDictionary - Methods - GetValue") 9 | 10 | - Properties 11 | - [DataCols](ObjectReference/Properties/DataCols.md "VBA-ExtendedDictionary - Properties - DataCols") 12 | - [DataRows](ObjectReference/Properties/DataRows.md "VBA-ExtendedDictionary - Properties - DataRows") 13 | - [OptionNoItemFail](ObjectReference/Properties/OptionNoItemFail.md "VBA-ExtendedDictionary - Properties - OptionNoItemFail") 14 | 15 | - Examples 16 | 17 | - [Count Instances](Examples/CountInstances.md "VBA-ExtendedDictionary - Examples - CountInstances") 18 | - [Export Data](Examples/ExportData.md "VBA-ExtendedDictionary - Examples - ExportData") 19 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | VBA-ExtendedDictionary 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 |
17 | 18 | 19 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /src/Dictionary.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Dictionary" 6 | Attribute VB_Description = "A wrapper that extends Scripting.Dictionary functionality." 7 | Attribute VB_GlobalNameSpace = False 8 | Attribute VB_Creatable = False 9 | Attribute VB_PredeclaredId = False 10 | Attribute VB_Exposed = False 11 | ' Copyright 2023 Sam Vanderslink 12 | ' sam.vanderslink@notis.net.au 13 | ' 14 | ' Permission is hereby granted, free of charge, to any person obtaining a copy 15 | ' of this software and associated documentation files (the "Software"), to deal 16 | ' in the Software without restriction, including without limitation the rights 17 | ' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 18 | ' copies of the Software, and to permit persons to whom the Software is 19 | ' furnished to do so, subject to the following conditions: 20 | ' 21 | ' The above copyright notice and this permission notice shall be included in 22 | ' all copies or substantial portions of the Software. 23 | ' 24 | ' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 25 | ' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 26 | ' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 27 | ' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 28 | ' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 29 | ' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 30 | ' IN THE SOFTWARE. 31 | 32 | Option Explicit 33 | 34 | '------------------------------------------------------------------------------- 35 | ' Class: Dictionary 36 | ' A wrapper that extends Scripting.Dictionary functionality. 37 | '------------------------------------------------------------------------------- 38 | ' Exceptions thrown by the Scripting.Dictionary bubble up to the Dictionary 39 | ' but do not seem to go further than that, even if you have your own error 40 | ' handling. That's why you'll see exception handling in here that rethrows the 41 | ' exception. This is so that it can be caught by the calling method. 42 | ' #JustVbaThings 43 | 44 | ' Enums 45 | '------------------------------------------------------------------------------- 46 | Enum CompareModeType 47 | ' Performs a comparison by using the setting of the Option Compare statement. 48 | vbUseCompareOption = -1 49 | 50 | ' Performs a binary comparison. 51 | vbBinaryCompare = 0 52 | 53 | ' Performs a textual comparison. 54 | vbTextCompare = 1 55 | 56 | ' Microsoft Access only. 57 | ' Performs a comparison based on information in your database. 58 | vbDatabaseCompare = 2 59 | End Enum 60 | 61 | 62 | ' Private Backing Store 63 | '------------------------------------------------------------------------------- 64 | Private mBaseDict As Object 65 | Private mOptionNoItemFail As Boolean 66 | Private mLargestValueSize 67 | 68 | 69 | ' Properties 70 | '------------------------------------------------------------------------------- 71 | Public Property Let OptionNoItemFail(val As Boolean) 72 | Attribute OptionNoItemFail.VB_Description = "Prevents a duplicative item add from raising an exception." 73 | ' Prevents a duplicative item add from raising an exception. 74 | ' 75 | ' When setting an item, it overwrites the existing one. 76 | ' When getting an item, it prevents the key from being added. 77 | ' 78 | mOptionNoItemFail = val 79 | End Property 80 | 81 | Public Property Get OptionNoItemFail() As Boolean 82 | OptionNoItemFail = mOptionNoItemFail 83 | End Property 84 | 85 | Public Property Let CompareMode(val As CompareModeType) 86 | Attribute CompareMode.VB_Description = "Sets the compare mode for the dictionary." 87 | ' Sets the compare mode for the dictionary. 88 | ' 89 | ' A value representing the comparison mode used by functions such 90 | ' as StrComp. Can only be changed while the dictionary has no data. 91 | mBaseDict.CompareMode = val 92 | End Property 93 | 94 | Public Property Get CompareMode() As CompareModeType 95 | CompareMode = mBaseDict.CompareMode 96 | End Property 97 | 98 | Public Property Get Count() As Variant 99 | Attribute Count.VB_Description = "Gets the count of the items in the dictionary." 100 | ' Gets the count of the items in the dictionary. 101 | Count = mBaseDict.Count 102 | End Property 103 | 104 | Public Property Let Item(Key As Variant, val As Variant) 105 | Attribute Item.VB_UserMemId = 0 106 | Attribute Item.VB_Description = "Sets or returns an item for a specified key in a Dictionary object." 107 | ' Sets or returns an item for a specified key in a Dictionary object. 108 | Try: 109 | On Error GoTo Catch 110 | mBaseDict.Item(Key) = val 111 | If Err = 0 Then MetaTrackingAdd val 112 | Exit Property 113 | 114 | Catch: 115 | If mOptionNoItemFail Then Exit Property 116 | Err.Raise Err 117 | End Property 118 | 119 | Public Property Set Item(Key As Variant, val As Variant) 120 | Try: 121 | On Error GoTo Catch 122 | Set mBaseDict.Item(Key) = val 123 | MetaTrackingAdd val 124 | Exit Property 125 | 126 | Catch: 127 | If mOptionNoItemFail Then Exit Property 128 | Err.Raise Err 129 | End Property 130 | 131 | Public Property Get Item(Key As Variant) As Variant 132 | If mOptionNoItemFail And Not mBaseDict.Exists(Key) Then Exit Property 133 | 134 | If IsObject(mBaseDict.Item(Key)) Then 135 | Set Item = mBaseDict.Item(Key) 136 | Else 137 | Item = mBaseDict.Item(Key) 138 | End If 139 | End Property 140 | 141 | Public Property Let Key(Key As Variant, NewKey As Variant) 142 | Attribute Key.VB_Description = "Updates an existing key with a new one." 143 | ' Updates an existing key with a new one. 144 | mBaseDict.Key(Key) = NewKey 145 | End Property 146 | 147 | Public Property Get GetValue(Key As Variant, Optional def As Variant) As Variant 148 | Attribute GetValue.VB_Description = "Gets a value for the specified key or returns the default. if not found" 149 | ' Gets a value for the specified key or returns the default if not found. 150 | If mBaseDict.Exists(Key) Then 151 | If IsObject(mBaseDict.Item(Key)) Then 152 | Set GetValue = mBaseDict.Item(Key) 153 | Else 154 | GetValue = mBaseDict.Item(Key) 155 | End If 156 | Else 157 | Select Case True 158 | Case Is = IsMissing(def): 159 | Set GetValue = Nothing 160 | Case Is = IsObject(def): 161 | Set GetValue = def 162 | Case Else: 163 | GetValue = def 164 | End Select 165 | End If 166 | End Property 167 | 168 | Public Property Get DataRows(Optional OptionUseRowMode As Boolean) As Long 169 | Attribute DataRows.VB_Description = "Returns the row count that would be returned by the GetData method" 170 | ' Returns the row count that would be returned by the GetData method. 171 | ' The values are always +1 to account for the first row being keys. 172 | ' 173 | ' OptionUseRowMode=True: Returns the longest array size of values 174 | ' plus row for keys (if they exist). 175 | ' OptionUseRowMode=False: Returns the count of the keys. 176 | DataRows = Iif(OptionUseRowMode, mLargestValueSize + LongMin(1, Me.Count), Me.Count) 177 | End Property 178 | 179 | Public Property Get DataCols(Optional OptionUseRowMode As Boolean) As Long 180 | Attribute DataRows.VB_Description = "Returns the column count that would be returned by the GetData method." 181 | ' Returns the column count that would be returned by the GetData method. 182 | ' The values are always +1 to account for the first col being keys. 183 | ' 184 | ' OptionUseRowMode=True: Returns the count of the keys. 185 | ' OptionUseRowMode=False: Returns the longest array size of values 186 | ' plus 1 col for keys (if they exist). 187 | DataCols = Iif(OptionUseRowMode, Me.Count, mLargestValueSize + LongMin(1, Me.Count)) 188 | End Property 189 | 190 | Public Property Get NewEnum() As IUnknown 191 | Attribute NewEnum.VB_Description = "Enables iteration with a For Each loop." 192 | Attribute NewEnum.VB_UserMemId = -4 193 | ' Enables iteration with a For Each loop. 194 | Set NewEnum = mBaseDict.[_NewEnum] 195 | End Property 196 | 197 | 198 | ' Constructor 199 | '------------------------------------------------------------------------------- 200 | Private Sub Class_Initialize() 201 | Set mBaseDict = CreateObject("Scripting.Dictionary") 202 | End Sub 203 | 204 | 205 | ' Methods 206 | '------------------------------------------------------------------------------- 207 | Public Sub Add(Key As Variant, Optional val As Variant = Nothing) 208 | Attribute Add.VB_Description = "Adds a key and value pair to the dictionary." 209 | ' Adds a key and value pair to the dictionary. 210 | ' 211 | ' If the dictionary is in NoItemFail mode, and the key exists, the value 212 | ' will be overwritten wrather than throwing a duplicate key exception. 213 | ' 214 | ' Args: 215 | ' Key: The key to add the value to. 216 | ' val: The value to add. 217 | ' 218 | On Error Resume Next 219 | mBaseDict.Add Key, val 220 | 221 | Select Case True 222 | Case Is = Err = 457 And mOptionNoItemFail 223 | If IsObject(val) Then 224 | Set Item(Key) = val 225 | Else 226 | Item(Key) = val 227 | End If 228 | Case Is = Err = 457 229 | Err.Raise vbObjectError + 457, "Dictionary", _ 230 | Key & " is already associated with the dictionary." 231 | Case Is = Err <> 0 232 | Err.Raise Err 233 | Case Else 234 | MetaTrackingAdd val 235 | End Select 236 | End Sub 237 | 238 | Public Sub Remove(Key As Variant) 239 | Attribute Remove.VB_Description = "Removes a key from the Scripting.Dictionary." 240 | ' Removes a key from the Scripting.Dictionary. 241 | ' 242 | ' Args: 243 | ' Key: The key to remove. 244 | ' 245 | Dim val As Variant 246 | If IsObject(Me.Item(Key)) Then 247 | Set val = Me.Item(Key) 248 | Else 249 | val = Me.Item(Key) 250 | End If 251 | mBaseDict.Remove Key 252 | MetaTrackingRemove val 253 | End Sub 254 | 255 | Public Sub RemoveAll() 256 | Attribute RemoveAll.VB_Description = "Removes all keys from the dictionary." 257 | ' Removes all keys from the dictionary. 258 | ' 259 | mBaseDict.RemoveAll 260 | mLargestValueSize = 0 261 | End Sub 262 | 263 | Public Sub AddBulk( _ 264 | ValueArray As Variant, _ 265 | Optional OptionUseRowMode As Boolean, _ 266 | Optional OptionCountKeys As Boolean, _ 267 | Optional DefaultValue As Variant, _ 268 | Optional HeadersIndex As Long = 1) 269 | Attribute AddBulk.VB_Description = "Adds key value pairs from a 1 or 2D array." 270 | ' Adds key value pairs from a 1 or 2D array. 271 | ' 272 | ' Supports keys as first row or firt column. Automatically detects array 273 | ' size and adds values based on number of values per key. 274 | ' 0: Keys only (values are Nothing) 275 | ' 1: Single values only 276 | ' >1: Values are a 1D array of values 277 | ' 278 | ' Args: 279 | ' ValueArray: The data to add to the dictionary. 280 | ' OptionUseRowMode: Use the first row instead of column as keys. 281 | ' OptionCountKeys: The value is the count of keys. 282 | ' DefaultValue: Set a default item value. 283 | ' HeadersIndex: Specify the header index or column. 284 | ' 285 | ' Notes: 286 | ' The use of OptionCountKeys implies duplicate keys so OptionNoItemFail 287 | ' will be forced to True regardless of its current setting. 288 | ' 289 | ' There is currently only support for 1-based arrays such that you would 290 | ' get with a Range, e.g., Range("A1:B10").Value = (1 To 10, 1 To 2). 291 | ' 292 | ' Dictionary key 293 | Dim v As Variant ' Dictionary value 294 | 295 | If OptionCountKeys Then mOptionNoItemFail = True 296 | 297 | ' Transpose the array if we're using row mode so that we can use the same 298 | ' logic to add bulk data to the dictionary (as if it is in column mode). 299 | If OptionUseRowMode Then 300 | ValueArray = Application.Transpose(ValueArray) 301 | End If 302 | 303 | ' Set the shape of the data. 304 | Dim rowCount As Long 305 | rowCount = UBound(ValueArray, 1) 306 | 307 | Dim isSingleDimension As Boolean 308 | isSingleDimension = CountArrayDimensions(ValueArray) = 1 309 | 310 | If Not isSingleDimension Then 311 | Dim colCount As Long 312 | colCount = UBound(ValueArray, 2) 313 | End If 314 | 315 | ' Add the keys and values to the dictionary. 316 | Dim i As Long 317 | For i = LBound(ValueArray, 1) To rowCount 318 | Dim k As Variant 319 | 320 | ' Handle a "headers only" type array. 321 | If isSingleDimension Then 322 | k = ValueArray(i) 323 | Me.Add k, Me.GetValue(k, 0) + 1 324 | GoTo Continue 325 | End If 326 | k = ValueArray(i, HeadersIndex) 327 | 328 | ' Determine the value and add it. 329 | Select Case True 330 | Case Is = OptionCountKeys: 331 | v = Me.GetValue(k, 0) + 1 332 | Case Is = colCount = 2: 333 | v = ValueArray(i, 2) 334 | Case Is = colCount > 2: 335 | v = GetDataValues(ValueArray, i, HeadersIndex) 336 | Case Else: 337 | If IsObject(DefaultValue) Then 338 | Set v = DefaultValue 339 | Else 340 | v = DefaultValue 341 | End If 342 | End Select 343 | Me.Add k, v 344 | Continue: 345 | Next i 346 | End Sub 347 | 348 | Public Function Exists(Key As Variant) As Boolean 349 | Attribute Exists.VB_Description = "Checks if a key exists in the dictionary." 350 | ' Checks if a key exists in the dictionary. 351 | ' 352 | ' Args: 353 | ' Key: The key to check. 354 | ' 355 | ' Returns: 356 | ' True if the key exists. 357 | ' 358 | Exists = mBaseDict.Exists(Key) 359 | End Function 360 | 361 | Public Function Items() As Variant() 362 | Attribute Items.VB_Description = "Returns all values in the dictionary." 363 | ' Returns all values in the dictionary. 364 | ' 365 | ' Returns: 366 | ' An array of values. 367 | ' 368 | Items = mBaseDict.Items 369 | End Function 370 | 371 | Public Function Keys() As Variant() 372 | Attribute Keys.VB_Description = "Returns all keys in the dictionary." 373 | ' Returns all keys in the dictionary. 374 | ' 375 | ' Returns: 376 | ' An array of keys. 377 | ' 378 | Keys = mBaseDict.Keys 379 | End Function 380 | 381 | Public Function GetData(Optional OptionUseRowMode As Boolean) As Variant 382 | Attribute GetData.VB_Description = "Returns the dictionary data as a 2D array with keys representing headers." 383 | ' Returns the dictionary data as a 2D array with keys representing headers. 384 | ' 385 | ' Args: 386 | ' OptionUseRowMode: Data is returned with keys as first column. 387 | ' 388 | ' Returns: 389 | ' A 2D array of keys and values. Arrays of values will be converted to 390 | ' row data, or column data if OptionUseRowMode is True. 391 | ' 392 | ' Set up the metadata to work with. 393 | Dim arrKeys As Variant 394 | arrKeys = mBaseDict.Keys() 395 | 396 | Dim arrVals As Variant 397 | arrVals = mBaseDict.Items() 398 | 399 | Dim dataRowCount As Long 400 | dataRowCount = Me.DataRows() 401 | 402 | Dim dataColCount As Long 403 | dataColCount = Me.DataCols() 404 | 405 | ' Set up results array in the shape of the keys and values 406 | ' adding an additional column to fit the keys as a column 407 | Dim results() As Variant 408 | ReDim results(1 To dataRowCount, _ 409 | 1 To dataColCount) 410 | 411 | ' Populate the row(s) and column(s) 412 | Dim r As Long 413 | For r = 1 To dataRowCount 414 | results(r, 1) = arrKeys(r - 1) 415 | If dataColCount > 2 Then 416 | ' Populate columns for multi-column 417 | Dim maxCols As Long 418 | maxCols = UBound(arrVals(r - 1)) + 2 419 | Dim c As Long 420 | For c = 2 To dataColCount 421 | results(r, c) = arrVals(r - 1)(c - 2) 422 | If c = maxCols Then Exit For 423 | Next c 424 | ElseIf dataColCount = 2 Then 425 | ' Populate single value 426 | results(r, 2) = arrVals(r - 1) 427 | End If 428 | Next r 429 | 430 | ' Return the data as normal or row mode. 431 | If OptionUseRowMode Then 432 | GetData = Application.Transpose(results) 433 | Else 434 | GetData = results 435 | End If 436 | End Function 437 | 438 | 439 | ' Helpers 440 | '------------------------------------------------------------------------------- 441 | Private Function GetDataValues(arr As Variant, rIdx As Long, hIdx As Long) As Variant 442 | Attribute GetDataValues.VB_Description = "Returns a 1D array of values from the data." 443 | ' Returns a 1D array of values from the data. 444 | ' 445 | ' Args: 446 | ' arr: The source array of values. 447 | ' rIdx: The index row. 448 | ' hIdx: The header (key) index. 449 | ' 450 | ' Returns: 451 | ' An array of values, minus the key. 452 | ' 453 | Dim result As Variant 454 | ReDim result(UBound(arr, 2) - 2) 455 | 456 | Dim i As Long 457 | For i = 1 To UBound(arr, 2) 458 | If i <> hIdx Then 459 | Result(i - IIf(i < hIdx, 1, 2)) = arr(rIdx, i) 460 | End If 461 | Next i 462 | 463 | GetDataValues = result 464 | End Function 465 | 466 | Private Function NArrayDimensions(arr As Variant) As Long 467 | Attribute NArrayDimensions.VB_Description = "Returns the number of dimensions for the passed in array." 468 | ' Returns the number of dimensions for the passed in array. 469 | ' 470 | ' This is a hack that intentionally seeks to raise and catch an 471 | ' exception as there is no property or elegant way to do this. 472 | ' 473 | ' Args: 474 | ' arr: The array to test. 475 | ' 476 | ' Returns: 477 | ' The number of dimensions for the passed in array. 478 | ' 479 | ' Raises: 480 | ' 481 | 482 | ' Test array dimensions until exception raised 483 | On Error GoTo Finally 484 | Dim i As Long 485 | Do 486 | i = i + 1 487 | NArrayDimensions = UBound(arr, i) 488 | Loop 489 | 490 | Finally: 491 | ' Expect to catch a Type mismatch exception. 492 | ' Expect to catch a Subscript out of range exception. 493 | If Err = 13 Or Err = 9 Then NArrayDimensions = i - 1 Else Err.Raise Err 494 | End Function 495 | 496 | Private Sub MetaTrackingAdd(val As Variant) 497 | Attribute MetaTrackingAdd.VB_Description = "Tracks the largest sized value array when adding a key to the dictionary." 498 | ' Tracks the largest sized value array when adding a key to the dictionary. 499 | ' 500 | ' Args: 501 | ' val: The value being added. 502 | ' 503 | Dim valSize As Long 504 | valSize = GetValueOrArraySize(val) 505 | If valSize > mLargestValueSize Then 506 | mLargestValueSize = valSize 507 | End If 508 | End Sub 509 | 510 | Private Sub MetaTrackingRemove(remVal As Variant) 511 | Attribute MetaTrackingRemove.VB_Description = "Tracks the largest sized value array when removing a key from the dictionary." 512 | ' Tracks the largest sized value array when removing a key from the dictionary. 513 | ' 514 | ' Args: 515 | ' remVal: The value being removed. 516 | ' 517 | ' Shortcut for when we have no values. 518 | If Count = 0 Then 519 | mLargestValueSize = 0 520 | End If 521 | 522 | ' Get the count of the value array we're removing. 523 | Dim removedValSize As Long 524 | removedValSize = GetValueOrArraySize(remVal) 525 | 526 | ' No need to test everything if the tracked value wasn't the largest. 527 | If mLargestValueSize > removedValSize Then Exit Sub 528 | 529 | Dim val As Variant 530 | Dim valSize As Long 531 | mLargestValueSize = 0 532 | For Each val In Me.Items 533 | valSize = GetValueOrArraySize(val) 534 | 535 | ' Shortcut if next largest is the same as value we're untracking. 536 | If valSize = removedValSize Then 537 | mLargestValueSize = valSize 538 | Exit Sub 539 | End If 540 | 541 | If valSize > mLargestValueSize Then 542 | mLargestValueSize = valSize 543 | End If 544 | Next val 545 | End Sub 546 | 547 | Private Function GetValueOrArraySize(val As Variant) As Long 548 | Attribute GetValueOrArraySize.VB_Description = "Returns the length of the array, 1 if not an array, and 0 if Nothing." 549 | ' Returns the length of the array, 1 if not an array, and 0 if Nothing. 550 | ' 551 | ' Args: 552 | ' val: The value or array to be tested. 553 | ' 554 | ' Returns: 555 | ' The count of values in an array, 1 if not an array, and 0 if Nothing. 556 | ' 557 | ' Type checking like this prevents an exception if not an object. 558 | If TypeName(val) = "Nothing" Then Exit Function 559 | 560 | Dim dims As Long 561 | dims = NArrayDimensions(val) 562 | 563 | If dims = 0 Then 564 | ' Not an array and not nothing. 565 | GetValueOrArraySize = 1 566 | Else 567 | ' Is an array, return the count. 568 | ' Assumes a single dimension, but that's all we'll have here. 569 | GetValueOrArraySize = UBound(val) + 1 570 | End If 571 | End Function 572 | 573 | Private Function LongMin(a As Long, b As Long) As Long 574 | Attribute LongMin.VB_Description = "Returns the smaller of the two passed in values." 575 | ' Returns the smaller of the two passed in values. 576 | ' 577 | ' Args: 578 | ' a: A value to be tested. 579 | ' b: A value to be tested. 580 | ' 581 | ' Returns: 582 | ' a if a is smaller, else b. 583 | ' 584 | LongMin = Iif(a < b, a, b) 585 | End Function 586 | 587 | Private Function CountArrayDimensions(arr As Variant) As Long 588 | Attribute Is2DArray.VB_Description = "Returns the number of dimensions in an array." 589 | ' Returns true if the array is 1D. 590 | ' 591 | On Error Resume Next 592 | Do 593 | Dim i As Long 594 | i = i + 1 595 | 596 | Dim var As Long 597 | var = UBound(arr, i) 598 | If Err <> 0 Then 599 | CountArrayDimensions = i - 1 600 | Exit Function 601 | End If 602 | Loop 603 | End Function 604 | -------------------------------------------------------------------------------- /test/DictionaryTests.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "DictionaryTests" 2 | ' Copyright 2023 Sam Vanderslink 3 | ' 4 | ' Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ' of this software and associated documentation files (the "Software"), to deal 6 | ' in the Software without restriction, including without limitation the rights 7 | ' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ' copies of the Software, and to permit persons to whom the Software is 9 | ' furnished to do so, subject to the following conditions: 10 | ' 11 | ' The above copyright notice and this permission notice shall be included in 12 | ' all copies or substantial portions of the Software. 13 | ' 14 | ' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | ' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 20 | ' IN THE SOFTWARE. 21 | 22 | Option Explicit 23 | 24 | 25 | Private passTests As New Collection 26 | Private failTests As New Collection 27 | 28 | Public Sub RunTests() 29 | Attribute RunTests.VB_Description = "Runs all tests." 30 | ' Runs all tests. 31 | ' 32 | Set passTests = New Collection 33 | Set failTests = New Collection 34 | 35 | Dim testName As Variant 36 | For Each testName In GetTestNames() 37 | RunTest CStr(testName) 38 | Next testName 39 | 40 | Dim p As Long, f As Long 41 | p = passTests.Count 42 | f = failTests.Count 43 | 44 | Debug.Print "-------------------------------------------" 45 | Debug.Print " Passed: " & p & " (" & Format(p / (p + f), "0.00%)") 46 | Debug.Print " Failed: " & f & " (" & Format(f / (p + f), "0.00%)") 47 | Debug.Print "-------------------------------------------" 48 | 49 | End Sub 50 | 51 | Sub RunSingle() 52 | Dim tr As TestResult 53 | Set tr = TestDictionary_AddKeyOnly() 54 | tr.Name = "TestDictionary_AddKeyOnly" 55 | Debug.Print tr.ToString 56 | End Sub 57 | 58 | Private Sub RunTest(testName As String) 59 | Attribute RunTest.VB_Description = "Runs the named test and stores the result." 60 | ' Runs the named test and stores the result. 61 | ' 62 | ' Args: 63 | ' testName: The name of the function returning a TestResult. 64 | ' 65 | Dim tr As TestResult 66 | Set tr = Application.Run(testName) 67 | tr.Name = testName 68 | Debug.Print tr.ToString 69 | 70 | If tr.Failed Then failTests.Add tr Else passTests.Add tr 71 | End Sub 72 | 73 | Private Function GetTestNames() As Collection 74 | Attribute GetTestNames.VB_Description = "Gets the test names from this module." 75 | ' Gets the test names from this module. 76 | ' A valid test starts with Private Function TestDictionary_ and takes no args. 77 | ' 78 | ' Returns: 79 | ' A collection of strings representing names of tests. 80 | ' 81 | Const MODULENAME As String = "DictionaryTests" 82 | Const FUNCTIONID As String = "Private Function " 83 | Const TESTSTARTW As String = "Private Function TestDictionary_" 84 | 85 | Dim tswLen As Long 86 | tswLen = Len(TESTSTARTW) 87 | 88 | Dim codeMod As Object 89 | Set codeMod = ThisWorkbook.VBProject.VBComponents(MODULENAME).CodeModule 90 | 91 | Dim i As Long 92 | Dim results As New Collection 93 | For i = 1 To codeMod.CountOfLines 94 | Dim lineContent As String 95 | lineContent = codeMod.Lines(i, 1) 96 | 97 | If Left(lineContent, tswLen) = TESTSTARTW Then 98 | Dim funcName As String 99 | funcName = Split(Split(lineContent, FUNCTIONID)(1), "(")(0) 100 | results.Add funcName 101 | End If 102 | Next i 103 | 104 | Set GetTestNames = results 105 | End Function 106 | 107 | Private Function TestDictionary_Add() As TestResult 108 | Attribute TestDictionary_Add.VB_Description = "Add an item to the dictionary." 109 | ' Add an item to the dictionary. 110 | Dim tr As New TestResult 111 | 112 | ' Arrange 113 | Const ADDKEY As String = "K" 114 | Const ADDVAL As String = "V" 115 | Dim d As New Dictionary 116 | 117 | ' Act 118 | On Error Resume Next 119 | d.Add ADDKEY, ADDVAL 120 | 121 | ' Assert 122 | If tr.AssertNoException() Then GoTo Finally 123 | On Error GoTo 0 124 | 125 | If tr.AssertAreEqual(1, d.Count) Then GoTo Finally 126 | If tr.AssertAreEqual(ADDVAL, d(ADDKEY)) Then GoTo Finally 127 | 128 | Finally: 129 | On Error GoTo 0 130 | Set TestDictionary_Add = tr 131 | End Function 132 | 133 | Private Function TestDictionary_AddKeyOnly() As TestResult 134 | Attribute TestDictionary_AddKeyOnly.VB_Description = "Adding a key with no value to the dictionary." 135 | ' Adding a key with no value to the dictionary. 136 | Dim tr As New TestResult 137 | 138 | ' Arrange 139 | Const ADDKEY As String = "K" 140 | Dim d As New Dictionary 141 | 142 | ' Act 143 | On Error Resume Next 144 | d.Add ADDKEY 145 | 146 | ' Assert 147 | If tr.AssertNoException() Then GoTo Finally 148 | On Error GoTo 0 149 | 150 | If tr.AssertAreEqual(1, d.Count) Then GoTo Finally 151 | If tr.AssertIsTrue(d.Exists(ADDKEY), "Key exists") Then GoTo Finally 152 | If tr.AssertAreEqual(Nothing, d(ADDKEY)) Then GoTo Finally 153 | 154 | Finally: 155 | On Error GoTo 0 156 | Set TestDictionary_AddKeyOnly = tr 157 | End Function 158 | 159 | Private Function TestDictionary_AddBulkColMode() As TestResult 160 | Attribute TestDictionary_AddBulkColMode.VB_Description = "Add bulk items to the dictionary." 161 | ' Add bulk items to the dictionary. 162 | Dim tr As New TestResult 163 | 164 | ' Arrange 165 | Dim bulkData() As Variant 166 | ReDim bulkData(1 To 3, 1 To 4) 167 | 168 | Const HDRS As String = "ABC" 169 | Const VALS As String = " 123" 170 | 171 | Dim i As Long 172 | For i = 1 To UBound(bulkData, 1) 173 | Dim j As Long 174 | For j = 1 To UBound(bulkData, 2) 175 | If j = 1 Then 176 | bulkData(i, j) = Mid(HDRS, i, 1) 177 | Else 178 | bulkData(i, j) = Mid(HDRS, i, 1) & Mid(VALS, j, 1) 179 | End If 180 | Next j 181 | Next i 182 | 183 | Dim d As New Dictionary 184 | 185 | ' Act 186 | On Error Resume Next 187 | d.AddBulk bulkData 188 | 189 | ' Assert 190 | If tr.AssertNoException() Then GoTo Finally 191 | On Error GoTo 0 192 | 193 | If tr.AssertAreEqual(Len(HDRS), d.Count) Then GoTo Finally 194 | 195 | For i = 1 To UBound(bulkData, 1) 196 | For j = 2 To UBound(bulkData, 2) 197 | If d(bulkData(i, 1))(j - 2) <> bulkData(i, j) Then 198 | tr.Failed = True 199 | tr.Message = "Dictionary data failed validation." 200 | End If 201 | Next j 202 | Next i 203 | 204 | Finally: 205 | On Error GoTo 0 206 | Set TestDictionary_AddBulkColMode = tr 207 | End Function 208 | 209 | Private Function TestDictionary_AddBulkRowMode() As TestResult 210 | Attribute TestDictionary_AddBulkRowMode.VB_Description = "Add bulk items to the dictionary." 211 | ' Add bulk items to the dictionary. 212 | Dim tr As New TestResult 213 | 214 | ' Arrange 215 | Dim bulkData() As Variant 216 | ReDim bulkData(1 To 3, 1 To 4) 217 | 218 | Const HDRS As String = "ABC" 219 | Const VALS As String = " 123" 220 | 221 | Dim i As Long 222 | For i = 1 To UBound(bulkData, 1) 223 | Dim j As Long 224 | For j = 1 To UBound(bulkData, 2) 225 | If j = 1 Then 226 | bulkData(i, j) = Mid(HDRS, i, 1) 227 | Else 228 | bulkData(i, j) = Mid(HDRS, i, 1) & Mid(VALS, j, 1) 229 | End If 230 | Next j 231 | Next i 232 | 233 | Dim d As New Dictionary 234 | 235 | ' Act 236 | On Error Resume Next 237 | d.AddBulk Application.Transpose(bulkData), OptionUseRowMode:=True 238 | 239 | ' Assert 240 | If tr.AssertNoException() Then GoTo Finally 241 | On Error GoTo 0 242 | 243 | If tr.AssertAreEqual(Len(HDRS), d.Count, "count headers") Then GoTo Finally 244 | 245 | For i = 1 To UBound(bulkData, 1) 246 | For j = 2 To UBound(bulkData, 2) 247 | If d(bulkData(i, 1))(j - 2) <> bulkData(i, j) Then 248 | tr.Failed = True 249 | tr.Message = "Dictionary data failed validation." 250 | End If 251 | Next j 252 | Next i 253 | 254 | Finally: 255 | On Error GoTo 0 256 | Set TestDictionary_AddBulkRowMode = tr 257 | End Function 258 | 259 | Private Function TestDictionary_AddBulkCountKeys() As TestResult 260 | Attribute TestDictionary_AddBulkCountKeys.VB_Description = "Add bulk items to the dictionary." 261 | ' Add bulk items to the dictionary. 262 | Dim tr As New TestResult 263 | 264 | ' Arrange 265 | Dim bulkData() As Variant 266 | ReDim bulkData(1 To 6, 1 To 1) 267 | 268 | Const HDRS As String = "ABC" 269 | Const VALS As String = "123" 270 | 271 | Dim i As Long 272 | For i = 1 To Len(HDRS) 273 | Dim j As Long 274 | For j = 1 To CLng(Mid(VALS, i, 1)) 275 | Dim n As Long 276 | n = n + 1 277 | bulkData(n, 1) = Mid(HDRS, i, 1) 278 | Next j 279 | Next i 280 | 281 | Dim d As New Dictionary 282 | 283 | ' Act 284 | On Error Resume Next 285 | d.AddBulk bulkData, OptionCountKeys:=True 286 | 287 | ' Assert 288 | If tr.AssertNoException() Then GoTo Finally 289 | On Error GoTo 0 290 | 291 | If tr.AssertAreEqual(Len(HDRS), d.Count, "count keys") Then GoTo Finally 292 | 293 | For i = 1 To Len(HDRS) 294 | Dim h As String, v As Long 295 | h = Mid(HDRS, i, 1) 296 | v = CLng(Mid(VALS, i, 1)) 297 | If tr.AssertAreEqual(v, d(h), h) Then Exit For 298 | Next i 299 | 300 | Finally: 301 | Set TestDictionary_AddBulkCountKeys = tr 302 | End Function 303 | 304 | Private Function TestDictionary_AddBulkCountKeysRowMode() As TestResult 305 | Attribute TestDictionary_AddBulkCountKeysRowMode.VB_Description = "Github issue #4 Counting keys using row mode errors with duplicate key." 306 | ' Github issue #4 Counting keys using row mode errors with duplicate key. 307 | Dim tr As New TestResult 308 | 309 | ' Arrange 310 | Dim bulkData() As Variant 311 | ReDim bulkData(1 To 6, 1 To 1) 312 | 313 | Const HDRS As String = "ABC" 314 | Const VALS As String = "123" 315 | 316 | Dim i As Long 317 | For i = 1 To Len(HDRS) 318 | Dim j As Long 319 | For j = 1 To CLng(Mid(VALS, i, 1)) 320 | Dim n As Long 321 | n = n + 1 322 | bulkData(n, 1) = Mid(HDRS, i, 1) 323 | Next j 324 | Next i 325 | 326 | Dim d As New Dictionary 327 | 328 | ' Act 329 | On Error Resume Next 330 | d.AddBulk Application.Transpose(bulkData), _ 331 | OptionCountKeys:=True, _ 332 | OptionUseRowMode:=True 333 | 334 | ' Assert 335 | If tr.AssertNoException() Then GoTo Finally 336 | On Error GoTo 0 337 | 338 | If tr.AssertAreEqual(Len(HDRS), d.Count, "count keys") Then GoTo Finally 339 | 340 | For i = 1 To Len(HDRS) 341 | Dim h As String, v As Long 342 | h = Mid(HDRS, i, 1) 343 | v = CLng(Mid(VALS, i, 1)) 344 | If tr.AssertAreEqual(v, d(h), h) Then Exit For 345 | Next i 346 | 347 | Finally: 348 | Set TestDictionary_AddBulkCountKeysRowMode = tr 349 | End Function 350 | 351 | Private Function TestDictionary_CountItems() As TestResult 352 | Attribute TestDictionary_CountItems.VB_Description = "Tests the Count property of the dictionary." 353 | ' Tests the Count property of the dictionary. 354 | ' 355 | Dim tr As New TestResult 356 | 357 | ' Arrange 358 | Const ADDKEYS As String = "ABCDEFGHIJKLMNOP" 359 | 360 | ' Act and Assert 361 | Dim d As New Dictionary 362 | If tr.AssertAreEqual(0, d.Count, "count keys") Then GoTo Finally 363 | 364 | Dim i As Long 365 | For i = 1 To Len(ADDKEYS) 366 | d.Add Mid(ADDKEYS, i, 1), Nothing 367 | If tr.AssertAreEqual(i, d.Count, "count keys at " & i) Then Exit For 368 | Next i 369 | 370 | Finally: 371 | Set TestDictionary_CountItems = tr 372 | End Function 373 | 374 | Private Function TestDictionary_ItemReturnsItem() As TestResult 375 | Attribute TestDictionary_ItemReturnsItem.VB_Description = "Tests the default and explicit item return." 376 | ' Tests the default and explicit item return. 377 | Dim tr As New TestResult 378 | 379 | ' Arrange 380 | Const EXPRESA As String = "A Result" 381 | Const EXPRESB As String = "B Result" 382 | Const INPKEYA As String = "A" 383 | Const INPKEYB As String = "B" 384 | 385 | ' Act 386 | Dim d As New Dictionary 387 | d.Add INPKEYA, EXPRESA 388 | d.Add INPKEYB, EXPRESB 389 | 390 | ' Assert 391 | If tr.AssertAreEqual(EXPRESA, d.Item(INPKEYA), INPKEYA) Then GoTo Finally 392 | If tr.AssertAreEqual(EXPRESB, d(INPKEYB), INPKEYB) Then GoTo Finally 393 | 394 | Finally: 395 | Set TestDictionary_ItemReturnsItem = tr 396 | End Function 397 | 398 | Private Function TestDictionary_Exists() As TestResult 399 | Attribute TestDictionary_Exists.VB_Description = "Tests Exists property works positively and negatively." 400 | ' Tests Exists property works positively and negatively. 401 | Dim tr As New TestResult 402 | 403 | ' Arrange 404 | Const INPKEYA As String = "A" 405 | Const INPKEYB As String = "B" 406 | Dim d As New Dictionary 407 | d.Add INPKEYA, Nothing 408 | 409 | ' Act 410 | Dim posResult As Boolean 411 | posResult = d.Exists(INPKEYA) 412 | 413 | Dim negResult As Boolean 414 | negResult = d.Exists(INPKEYB) 415 | 416 | ' Assert 417 | If tr.AssertIsTrue(posResult, "positive check") Then GoTo Finally 418 | If tr.AssertIsFalse(negResult, "negative check") Then GoTo Finally 419 | 420 | Finally: 421 | Set TestDictionary_Exists = tr 422 | End Function 423 | 424 | Private Function TestDictionary_GetItemsReturnsAllItems() As TestResult 425 | Attribute TestDictionary_GetItemsReturnsAllItems.VB_Description = "Test Items returns all items." 426 | ' Test Items returns all items. 427 | Dim tr As New TestResult 428 | 429 | ' Arrange 430 | Const EXPRESA As String = "A Result" 431 | Const EXPRESB As String = "B Result" 432 | Const INPKEYA As String = "A" 433 | Const INPKEYB As String = "B" 434 | 435 | Dim d As New Dictionary 436 | d.Add INPKEYA, EXPRESA 437 | d.Add INPKEYB, EXPRESB 438 | 439 | ' Act 440 | Dim result As Variant 441 | result = d.Items() 442 | 443 | ' Assert 444 | On Error Resume Next 445 | If tr.AssertAreEqual(EXPRESA, result(0), INPKEYA) Then GoTo Finally 446 | If tr.AssertAreEqual(EXPRESB, result(1), INPKEYB) Then GoTo Finally 447 | If tr.AssertNoException() Then GoTo Finally 448 | 449 | Finally: 450 | Set TestDictionary_GetItemsReturnsAllItems = tr 451 | End Function 452 | 453 | Private Function TestDictionary_GetKeysReturnsKeys() As TestResult 454 | Attribute TestDictionary_GetKeysReturnsKeys.VB_Description = "Test Keys returns all keys." 455 | ' Test Keys returns all keys. 456 | Dim tr As New TestResult 457 | 458 | ' Arrange 459 | Const INPKEYA As String = "A" 460 | Const INPKEYB As String = "B" 461 | 462 | Dim d As New Dictionary 463 | d.Add INPKEYA, Nothing 464 | d.Add INPKEYB, Nothing 465 | 466 | ' Act 467 | Dim result As Variant 468 | result = d.Keys() 469 | 470 | ' Assert 471 | On Error Resume Next 472 | If tr.AssertAreEqual(INPKEYA, result(0)) Then GoTo Finally 473 | If tr.AssertAreEqual(INPKEYB, result(1)) Then GoTo Finally 474 | If tr.AssertNoException() Then GoTo Finally 475 | 476 | Finally: 477 | Set TestDictionary_GetKeysReturnsKeys = tr 478 | End Function 479 | 480 | Private Function TestDictionary_GetDataReturnsData() As TestResult 481 | Attribute TestDictionary_GetDataReturnsData.VB_Description = "Test data out matches data in." 482 | ' Test data out matches data in. 483 | Dim tr As New TestResult 484 | 485 | ' Arrange 486 | Dim bulkData() As Variant 487 | ReDim bulkData(1 To 3, 1 To 4) 488 | 489 | Const HDRS As String = "ABC" 490 | Const VALS As String = " 123" 491 | 492 | Dim i As Long 493 | For i = 1 To UBound(bulkData, 1) 494 | Dim j As Long 495 | For j = 1 To UBound(bulkData, 2) 496 | If j = 1 Then 497 | bulkData(i, j) = Mid(HDRS, i, 1) 498 | Else 499 | bulkData(i, j) = Mid(HDRS, i, 1) & Mid(VALS, j, 1) 500 | End If 501 | Next j 502 | Next i 503 | 504 | On Error Resume Next 505 | Dim d As New Dictionary 506 | d.AddBulk bulkData 507 | 508 | ' Act 509 | Dim results As Variant 510 | results = d.GetData() 511 | 512 | ' Assert 513 | If tr.AssertNoException() Then GoTo Finally 514 | On Error GoTo 0 515 | 516 | For i = 1 To UBound(bulkData, 1) 517 | For j = 2 To UBound(bulkData, 2) 518 | If results(i, j) <> bulkData(i, j) Then 519 | tr.Failed = True 520 | tr.Message = "Dictionary data failed validation." 521 | End If 522 | Next j 523 | Next i 524 | 525 | Finally: 526 | Set TestDictionary_GetDataReturnsData = tr 527 | End Function 528 | 529 | Private Function TestDictionary_OptionNoItemFailOverwrites() As TestResult 530 | Attribute TestDictionary_OptionNoItemFailOverwrites.VB_Description = "OptionNoItemFail overwrites rather than throwing." 531 | ' OptionNoItemFail overwrites rather than throwing. 532 | Dim tr As New TestResult 533 | 534 | ' Arrange 535 | Const INPKEYA As String = "A" 536 | Const INPVALA As String = "A Value" 537 | Const INPVALB As String = "Visibly different value to A" 538 | 539 | ' Act 540 | Dim d As New Dictionary 541 | d.OptionNoItemFail = True 542 | 543 | On Error Resume Next 544 | d.Add INPKEYA, INPVALA 545 | d.Add INPKEYA, INPVALB 546 | 547 | ' Assert 548 | If tr.AssertNoException() Then GoTo Finally 549 | On Error GoTo 0 550 | 551 | If tr.AssertAreEqual(1, d.Count, "count") Then GoTo Finally 552 | If tr.AssertAreEqual(INPVALB, d(INPKEYA), INPKEYA) Then GoTo Finally 553 | 554 | Finally: 555 | Set TestDictionary_OptionNoItemFailOverwrites = tr 556 | End Function 557 | 558 | Private Function TestDictionary_NoOptionNoItemFailThrows() As TestResult 559 | Attribute TestDictionary_NoOptionNoItemFailThrows.VB_Description = "Without OptionNoItemFail throws rather than overwriting." 560 | ' Without OptionNoItemFail throws rather than overwriting. 561 | ' This test requires "Error Handling > Break on Unhandled Errors" set. 562 | ' If "Break in class module" is set, the 563 | Dim tr As New TestResult 564 | 565 | ' Arrange 566 | Const DUPLICATEKEYEX As Long = 457 567 | Const INPKEYA As String = "A" 568 | Const INPVALA As String = "A Value" 569 | Const INPVALB As String = "A Value" 570 | 571 | ' Act 572 | Dim d As New Dictionary 573 | d.OptionNoItemFail = False 574 | 575 | d.Add INPKEYA, INPVALA 576 | On Error Resume Next 577 | d.Add INPKEYA, INPVALB 578 | 579 | ' Assert 580 | If tr.AssertRaised(vbObjectError + DUPLICATEKEYEX) Then GoTo Finally 581 | On Error GoTo 0 582 | 583 | If tr.AssertAreEqual(1, d.Count, "count") Then GoTo Finally 584 | If tr.AssertAreEqual(INPVALA, d(INPKEYA), INPKEYA) Then GoTo Finally 585 | 586 | Finally: 587 | Set TestDictionary_NoOptionNoItemFailThrows = tr 588 | End Function 589 | 590 | Private Function TestDictionary_DataRowsAndColsCorrect() As TestResult 591 | Attribute TestDictionary_DataRowsAndColsCorrect.VB_Description = "Tests the DataRows and DataCols properties." 592 | ' Tests the DataRows and DataCols properties. 593 | Dim tr As New TestResult 594 | 595 | ' Arrange 596 | Dim bulkData() As Variant 597 | ReDim bulkData(1 To 3, 1 To 4) 598 | 599 | Const HDRS As String = "ABC" 600 | Const VALS As String = " 123" 601 | 602 | Dim i As Long 603 | For i = 1 To UBound(bulkData, 1) 604 | Dim j As Long 605 | For j = 1 To UBound(bulkData, 2) 606 | If j = 1 Then 607 | bulkData(i, j) = Mid(HDRS, i, 1) 608 | Else 609 | bulkData(i, j) = Mid(HDRS, i, 1) & Mid(VALS, j, 1) 610 | End If 611 | Next j 612 | Next i 613 | 614 | On Error Resume Next 615 | Dim d As New Dictionary 616 | d.AddBulk bulkData 617 | 618 | ' Act 619 | Dim dRowsColMode As Long 620 | dRowsColMode = d.DataRows() 621 | 622 | Dim dColsColMode As Long 623 | dColsColMode = d.DataCols() 624 | 625 | Dim dRowsRowMode As Long 626 | dRowsRowMode = d.DataRows(OptionUseRowMode:=True) 627 | 628 | Dim dColsRowMode As Long 629 | dColsRowMode = d.DataCols(OptionUseRowMode:=True) 630 | 631 | ' Assert 632 | If tr.AssertNoException() Then GoTo Finally 633 | On Error GoTo 0 634 | 635 | If tr.AssertAreEqual(UBound(bulkData, 1), dRowsColMode) Then GoTo Finally 636 | If tr.AssertAreEqual(UBound(bulkData, 2), dColsColMode) Then GoTo Finally 637 | If tr.AssertAreEqual(UBound(bulkData, 2), dRowsRowMode) Then GoTo Finally 638 | If tr.AssertAreEqual(UBound(bulkData, 1), dColsRowMode) Then GoTo Finally 639 | 640 | Finally: 641 | Set TestDictionary_DataRowsAndColsCorrect = tr 642 | End Function 643 | 644 | Private Function TestDictionary_RemoveRemovesKey() As TestResult 645 | Attribute TestDictionary_RemoveRemovesKey.VB_Description = "Test that remove removes the key." 646 | ' Test that remove removes the key. 647 | Dim tr As New TestResult 648 | 649 | ' Arrange 650 | Const INPKEYA As String = "A" 651 | Const INPKEYB As String = "B" 652 | 653 | Dim d As New Dictionary 654 | d.Add INPKEYA, Nothing 655 | d.Add INPKEYB, Nothing 656 | 657 | ' Act 658 | d.Remove(INPKEYA) 659 | 660 | ' Assert 661 | On Error Resume Next 662 | If tr.AssertIsFalse(d.Exists(INPKEYA), "key A exists") Then GoTo Finally 663 | If tr.AssertIsTrue(d.Exists(INPKEYB), "key B exists") Then GoTo Finally 664 | If tr.AssertNoException() Then GoTo Finally 665 | 666 | Finally: 667 | On Error GoTo 0 668 | Set TestDictionary_RemoveRemovesKey = tr 669 | End Function 670 | 671 | Private Function TestDictionary_RemoveUpdatesMeta() As TestResult 672 | Attribute TestDictionary_RemoveUpdatesMeta.VB_Description = "Github issue #3 Array tracking when largest element is removed." 673 | ' Github issue #3 Array tracking when largest element is removed. 674 | Dim tr As New TestResult 675 | 676 | ' Arrange 677 | Const INPKEYA As String = "A" 678 | Const INPKEYB As String = "B" 679 | 680 | Dim inpValA() As Variant 681 | inpValA = Array(1, 2) 682 | 683 | Dim inpValB() As Variant 684 | inpValB = Array(1, 2, 3, 4) 685 | 686 | Dim d As New Dictionary 687 | d.Add INPKEYA, inpValA 688 | d.Add INPKEYB, inpValB 689 | 690 | ' Act 691 | Dim beforeRemoveColCount As Long 692 | beforeRemoveColCount = d.DataCols() 693 | 694 | d.Remove INPKEYB 695 | 696 | Dim afterRemoveColCount As Long 697 | afterRemoveColCount = d.DataCols() 698 | 699 | ' Assert 700 | On Error Resume Next 701 | If tr.AssertAreNotEqual(beforeRemoveColCount, afterRemoveColCount, "row counts") Then GoTo Finally 702 | If tr.AssertAreEqual(UBound(inpValB) + 2, beforeRemoveColCount) Then GoTo Finally 703 | If tr.AssertAreEqual(UBound(inpValA) + 2, afterRemoveColCount) Then GoTo Finally 704 | If tr.AssertNoException() Then GoTo Finally 705 | 706 | Finally: 707 | On Error GoTo 0 708 | Set TestDictionary_RemoveUpdatesMeta = tr 709 | End Function 710 | 711 | Private Function TestDictionary_ExistWorksWithInteger() As TestResult 712 | Attribute TestDictionary_ExistWorksWithInteger.VB_Description = "Github Issue #5 Integer keys are never found with .Exists method." 713 | ' Github Issue #5 Integer keys are never found with .Exists method. 714 | Dim tr As New TestResult 715 | 716 | ' Arrange 717 | Dim d As New Dictionary 718 | d.Add 0, Nothing 719 | 720 | ' Act 721 | Dim result As Boolean 722 | result = d.Exists(0) 723 | 724 | ' Assert 725 | If tr.AssertIsTrue(result, "result exists") Then GoTo Finally 726 | 727 | 728 | Finally: 729 | Set TestDictionary_ExistWorksWithInteger = tr 730 | End Function 731 | 732 | Private Function TestDictionary_GetDataWorksWithVariableArrays() As TestResult 733 | Attribute TestDictionary_GetDataWorksWithVariableArrays.VB_Description = "Github issue #2 Unexpected value array sizes can cause GetData to raise out of bounds error." 734 | ' Github issue #2 Unexpected value array sizes can cause GetData to raise out of bounds error. 735 | Dim tr As New TestResult 736 | 737 | ' Arrange 738 | Const INPKEYA As String = "A" 739 | Const INPKEYB As String = "B" 740 | 741 | Dim inpValA() As Variant 742 | inpValA = Array(1, 2) 743 | 744 | Dim inpValB() As Variant 745 | inpValB = Array(1, 2, 3, 4) 746 | 747 | Dim d As New Dictionary 748 | d.Add INPKEYA, inpValA 749 | d.Add INPKEYB, inpValB 750 | 751 | ' Act 752 | Dim results() As Variant 753 | results = d.GetData() 754 | 755 | ' Assert 756 | If tr.AssertAreEqual(UBound(inpValB) + 2, UBound(results, 2)) Then GoTo Finally 757 | 758 | Finally: 759 | Set TestDictionary_GetDataWorksWithVariableArrays = tr 760 | End Function 761 | 762 | Private Function TestDictionary_ForEach() As TestResult 763 | Attribute TestDictionary_ForEach.VB_Description = "Tests the For Each functionality on keys." 764 | ' Tests the For Each functionality on keys. 765 | Dim tr As New TestResult 766 | 767 | ' Arrange 768 | Dim inpKeys() As Variant 769 | inpKeys = Array("a", "b", "c") 770 | 771 | Dim inpVals() As Variant 772 | inpVals = Array(1, 2, 3) 773 | 774 | Dim d As New Dictionary 775 | Dim i As Long 776 | For i = 0 To UBound(inpKeys) 777 | d.Add inpKeys(i), inpVals(i) 778 | Next i 779 | 780 | ' Act and Assert 781 | i = 0 782 | Dim k As Variant 783 | For Each k In d.Keys 784 | If Not tr.AssertAreEqual(inpKeys(i), k) Then GoTo Finally 785 | If Not tr.AssertAreEqual(inpVals(i), d(k)) Then GoTo Finally 786 | i = i + 1 787 | Next k 788 | 789 | Finally: 790 | Set TestDictionary_ForEach = tr 791 | End Function 792 | 793 | Private Function TestDictionary_GetValueGetsValue() As TestResult 794 | Attribute TestDictionary_GetValueGetsValue.VB_Description = "Get value where key exists." 795 | ' Get value where key exists. 796 | Dim tr As New TestResult 797 | 798 | ' Arrange 799 | Const EXPRESA As String = "A Result" 800 | Const EXPRESB As String = "B Result" 801 | Const INPKEYA As String = "A" 802 | Const INPKEYB As String = "B" 803 | 804 | ' Act 805 | Dim d As New Dictionary 806 | d.Add INPKEYA, EXPRESA 807 | 808 | ' Assert 809 | If tr.AssertAreEqual(EXPRESA, d.GetValue(INPKEYA, EXPRESB), INPKEYA) Then GoTo Finally 810 | If tr.AssertAreNotEqual(EXPRESB, d.GetValue(INPKEYB, EXPRESA), INPKEYB) Then GoTo Finally 811 | If tr.AssertIs(Nothing, d.GetValue(INPKEYB), INPKEYB & " - no default") Then GoTo Finally 812 | 813 | Finally: 814 | Set TestDictionary_GetValueGetsValue = tr 815 | End Function 816 | -------------------------------------------------------------------------------- /test/TestResult.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "TestResult" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright 2023 Sam Vanderslink 11 | ' 12 | ' Permission is hereby granted, free of charge, to any person obtaining a copy 13 | ' of this software and associated documentation files (the "Software"), to deal 14 | ' in the Software without restriction, including without limitation the rights 15 | ' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 16 | ' copies of the Software, and to permit persons to whom the Software is 17 | ' furnished to do so, subject to the following conditions: 18 | ' 19 | ' The above copyright notice and this permission notice shall be included in 20 | ' all copies or substantial portions of the Software. 21 | ' 22 | ' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 23 | ' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 24 | ' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 25 | ' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 26 | ' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 27 | ' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 28 | ' IN THE SOFTWARE. 29 | 30 | Option Explicit 31 | 32 | '------------------------------------------------------------------------------- 33 | ' Class: TestResult 34 | ' Simple data class containing a test result. 35 | '------------------------------------------------------------------------------- 36 | 37 | ' Properties 38 | '------------------------------------------------------------------------------- 39 | Public Name As String 40 | Public Failed As Boolean 41 | Public Message As String 42 | 43 | Public Property Get ToString() As String 44 | Attribute ToString.VB_Description = "Returns a string representation of the class." 45 | ' Returns a string representation of the class. 46 | Dim msg As String 47 | msg = Iif(Message = "", "", vbNewLine & " " & Message) 48 | ToString = Iif(Failed, "!! Fail: ", " Pass: ") & Name & msg 49 | End Property 50 | 51 | 52 | ' Methods 53 | '------------------------------------------------------------------------------- 54 | Public Function AssertAreEqual( _ 55 | expectedVal, _ 56 | actualVal, _ 57 | Optional forVal As String) As Boolean 58 | Attribute AssertAreEqual.VB_Description = "Asserts expected is equal to actual." 59 | ' Asserts expected is equal to actual. 60 | ' 61 | ' Args: 62 | ' expectedVal: The expected value. 63 | ' actualVal: The actual value. 64 | ' forVal: Additional context. 65 | ' 66 | ' Returns: 67 | ' False if the assertion passed. 68 | ' 69 | Select Case True 70 | ' Only one value is an object. 71 | Case Is = IsObject(expectedVal) Xor IsObject(actualVal): 72 | Failed = True 73 | SetExpectedActualMessage _ 74 | TypeName(expectedVal), _ 75 | TypeName(actualVal), _ 76 | forVal 77 | ' Both values are objects (test reference). 78 | Case Is = IsObject(expectedVal) And IsObject(actualVal): 79 | If Not expectedVal Is actualVal Then 80 | Failed = True 81 | SetExpectedActualMessage _ 82 | TypeName(expectedVal), _ 83 | TypeName(actualVal), _ 84 | forVal 85 | End If 86 | ' Neither values are objects. 87 | Case Else: 88 | If expectedVal <> actualVal Then 89 | Failed = True 90 | SetExpectedActualMessage CStr(expectedVal), CStr(actualVal), forVal 91 | End If 92 | End Select 93 | 94 | AssertAreEqual = Failed 95 | End Function 96 | 97 | Public Function AssertAreNotEqual( _ 98 | expectedVal, _ 99 | actualVal, _ 100 | Optional forVal As String) As Boolean 101 | Attribute AssertAreNotEqual.VB_Description = "Asserts values are not equal." 102 | ' Asserts values are not equal. 103 | ' 104 | ' Args: 105 | ' expectedVal: The expected value. 106 | ' actualVal: The actual value. 107 | ' forVal: Additional context. 108 | ' 109 | ' Returns: 110 | ' False if the assertion passed. 111 | ' 112 | If expectedVal = actualVal Then 113 | Failed = True 114 | Message = "Inequality check [" & forVal & "]" 115 | End If 116 | AssertAreNotEqual = Failed 117 | End Function 118 | 119 | Public Function AssertIsTrue(val As Boolean, ctx As String) As Boolean 120 | Attribute AssertIsTrue.VB_Description = "Asserts the value is true." 121 | ' Asserts the value is true. 122 | ' 123 | ' Args: 124 | ' val: The value to test. 125 | ' ctx: Context for the message. 126 | ' 127 | ' Returns: 128 | ' False if the assertion passed. 129 | ' 130 | If Not val Then 131 | Failed = True 132 | Message = "Is not true [" & ctx & "]" 133 | End If 134 | 135 | AssertIsTrue = Failed 136 | End Function 137 | 138 | Public Function AssertIsFalse(val As Boolean, ctx As String) As Boolean 139 | Attribute AssertIsFalse.VB_Description = "Asserts the value is false." 140 | ' Asserts the value is false. 141 | ' 142 | ' Args: 143 | ' val: The value to test. 144 | ' ctx: Context for the message. 145 | ' 146 | ' Returns: 147 | ' False if the assertion passed. 148 | ' 149 | If val Then 150 | Failed = True 151 | Message = "Failed " & ctx 152 | End If 153 | 154 | AssertIsFalse = Failed 155 | End Function 156 | 157 | Public Function AssertIs(objA As Object, objB As Object, ctx As String) As Boolean 158 | Attribute AssertIs.VB_Description = "Asserts two references are the same object." 159 | ' Asserts two references are the same object. 160 | ' 161 | ' Args: 162 | ' objA: The first object. 163 | ' objB: The second object. 164 | ' 165 | ' Returns: 166 | ' False if the assertion passed. 167 | ' 168 | If Not objA Is objB Then 169 | Failed = True 170 | Message = "Object References do not match for " & ctx & "." 171 | End If 172 | AssertIs = Failed 173 | End Function 174 | 175 | Public Function AssertNoException() As Boolean 176 | Attribute AssertNoException.VB_Description = "Asserts no exception raised." 177 | ' Asserts no exception raised. 178 | ' 179 | ' Args: 180 | ' errObj: The error object. 181 | ' 182 | ' Returns: 183 | ' False if the assertion passed. 184 | ' 185 | If Err <> 0 Then 186 | Failed = True 187 | Message = Err & " - " & Err.Description 188 | End If 189 | 190 | AssertNoException = Failed 191 | End Function 192 | 193 | Public Function AssertRaised(errNo As Long) As Boolean 194 | Attribute AssertRaises.VB_Description = "Asserts a specific exception is raised." 195 | ' Asserts a specific exception is raised. 196 | ' 197 | ' Args: 198 | ' errNo: The expected exception. 199 | ' 200 | ' Returns: 201 | ' False if the assertion passed. 202 | ' 203 | If Err = 0 Then 204 | Failed = True 205 | Message = "Expected exception " & errNo & " raised but none thrown." 206 | End If 207 | 208 | If Err <> errNo Then 209 | Failed = True 210 | Message = "Expected exception " & errNo & " raised but got " & Err & "." 211 | End If 212 | 213 | AssertRaised = Failed 214 | End Function 215 | 216 | 217 | ' Helpers 218 | '------------------------------------------------------------------------------- 219 | Private Sub SetExpectedActualMessage(exp As String, act As String, Optional forVal As String) 220 | Attribute SetExpectedActualMessage.VB_Description = "Sets a message based on expected vs actual values." 221 | ' Sets a message based on expected vs actual values. 222 | ' 223 | ' Args: 224 | ' exp: The expected value. 225 | ' act: The actual value. 226 | ' 227 | Dim msg As String 228 | msg = "Expected " & exp & " but got " & act 229 | Message = Iif(forVal = "", msg, msg & " [" & forVal & "]") 230 | End Sub 231 | --------------------------------------------------------------------------------