To Collect or Hash
VBA.Collection has a number of limitations, but it is enumerable and you can refer to items by index or key. But the VBA implementation of a Collection is 1-based, and they don't have any way of confirming membership, and the
Item method returns a
Variant, so they're loosely typed. Did I say
Item method? Yes, that's right,
Item is a method. Let's make it a property while we're at it.
Dictionaries aren't enumerable, but they have useful methods like
RemoveAll. They're implemented as hash-tables behind the scenes, so they're faster than Collections for retrieving members and/or for confirming membership.
What if I could combine the best features of Collections and Dictionaries?
- 0 or 1 based (user configurable)
- Strongly typed
Itemmethod is default member, and it's a property
Existsmethod for membership checks
- Add a Widget to the collection without having to specify a key
And why not throw in a factory method too, although some might argue it's a return to the year 2000.
In order to get the enumerable features of a Collection, I'll have to use a Collection behind the scenes, but I'll augment that with a Dictionary that keeps track of the keys used in the Collection. Then, when I want to test the
Exists method, I can check the Dictionary (and get all of it's hash-tabled goodness) instead of enumerating the Collection or suppressing a potential error by checking the index/key directly.
I also want to make the Collection configurable so that it can be 0 or 1 based according to preference. I've made this setting private to the Collection, so it's up to the developer to adjust for the purpose at hand, but it could easily be exposed as property or set in a factory method.
Pass the WidgetFirst, we need a class for the objects that we'll put into our custom collection. A
Widgetwill do nicely. Nothing special here - just a class with a few encapsulated fields, and a bonus read-only property for returning an instance of itself.
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "Widget" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Description = "The Widget is the core of our business." Option Explicit Private Type TWidget ID As String Name As String ReleaseDate As Date End Type Private this As TWidget Public Property Get ID() As String Attribute ID.VB_Description = "The unique identifier of the Widget" ID = this.ID End Property Public Property Let ID(ByVal Value As String) this.ID = Value End Property Public Property Get Name() As String Attribute Name.VB_Description = "The name of the Widget" Name = this.Name End Property Public Property Let Name(ByVal Value As String) this.Name = Value End Property Public Property Get ReleaseDate() As Date Attribute ReleaseDate.VB_Description = "The release date of the Widget" ReleaseDate = this.ReleaseDate End Property Public Property Let ReleaseDate(ByVal Value As Date) this.ReleaseDate = Value End Property Public Property Get Self() As Widget Attribute Self.VB_Description = "Returns an instance of this Widget" Set Self = Me End Property
Collect all the Widgets
Then we need a class to hold all of the widgets. The all important method for enumerating the collection is
NewEnum which has a special attribute
VB_UserMemId = -4 set. The class also has a factory method for creating a Widget (Without actually adding it to the collection).
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "Widgets" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Description = "A custom collection for enumerating Widgets." Option Explicit Private Enum CollectionBase Base0 = 0 Base1 = 1 End Enum Private Const COLLECTION_BASE As Long = CollectionBase.Base0 Private Type TWidgets Collection As Collection Keys As Scripting.Dictionary End Type Private this As TWidgets Private Sub Class_Initialize() Set this.Collection = New Collection Set this.Keys = New Scripting.Dictionary End Sub Public Function NewEnum() As IUnknown Attribute NewEnum.VB_UserMemId = -4 Attribute NewEnum.VB_Description = "The magic enumerator method with UserMemId = -4." Set NewEnum = this.Collection.[_NewEnum] End Function Public Sub Add(ByRef Widget As Widget) Attribute Add.VB_Description = "Adds a widget to the collection." Dim Key As String Key = Widget.ID If Not this.Keys.Exists(Key) Then this.Collection.Add Widget, Key this.Keys.Add Key, this.Collection.Count Else Err.Raise 457, "Widget.Add", "The key '" & Key & "' is already associated with an element of this collection" End If End Sub Public Function CreateWidget(ByVal ID As String, ByVal Name As String, ByVal ReleaseDate As Date) As Widget Attribute CreateWidget.VB_Description = "A factory method for creating a new Widget." With New Widget .ID = ID .Name = Name .ReleaseDate = ReleaseDate Set CreateWidget = .Self End With End Function Property Get Count() As Long Attribute Count.VB_Description = "Returns the number Widgets in the collection." Count = this.Keys.Count End Property Public Function Exists(ByVal ID As String) As Boolean Attribute Exists.VB_Description = "Confirms whether a particular Widget exists in the collection." Exists = this.Keys.Exists(ID) End Function Public Property Get Item(ByVal IDOrIndex As Variant) As Widget Attribute Item.VB_Description = "Default Property. Returns a Widget by ID or Index." Attribute Item.VB_UserMemId = 0 Dim index As Long If this.Keys.Exists(IDOrIndex) Then index = this.Keys(IDOrIndex) Else If IsLongInteger(IDOrIndex) Then index = CLng(IDOrIndex) + (1 - COLLECTION_BASE) If index < 1 Or index > this.Collection.Count Then Err.Raise 9, "Widgets.Item", "Index " & IDOrIndex & " is out of range. Widgets is " & COLLECTION_BASE & "-based""" Exit Property End If Else Err.Raise 9, "Widgets.Item", "ID '" & IDOrIndex & "' is out of range." Exit Property End If End If Set Item = this.Collection.Item(index) End Property Public Sub Remove(ByVal IDOrIndex As Variant) Attribute Remove.VB_Description = "Removes a Widget by ID/Key or Index." Dim oneBasedIndex As Long Dim Key As String If this.Keys.Exists(IDOrIndex) Then Key = IDOrIndex oneBasedIndex = this.Keys(Key) Else If IsLongInteger(IDOrIndex) Then oneBasedIndex = CLng(IDOrIndex) + (1 - COLLECTION_BASE) If oneBasedIndex >= 1 And oneBasedIndex <= this.Collection.Count Then Key = this.Keys.Keys(oneBasedIndex - 1) Else Err.Raise 9, "Widgets.Remove", "Index " & IDOrIndex & " is out of range. Widgets is " & COLLECTION_BASE & "-based" End If Else Err.Raise 9, "Widgets.Remove", "Key '" & IDOrIndex & "' is out of range." End If End If this.Collection.Remove oneBasedIndex this.Keys.Remove Key Dim Keys As Variant Keys = this.Keys.Keys Dim items As Variant items = this.Keys.items Dim nextkey As String Dim nextIndex As Long 'Now decrement the indexes for all subsequent keys For nextIndex = oneBasedIndex - 1 To this.Keys.Count - 1 nextkey = this.Keys.Keys(nextIndex) this.Keys.Item(nextkey) = nextIndex + 1 items = this.Keys.items Keys = this.Keys.Keys Next nextIndex End Sub Public Sub RemoveAll() Attribute RemoveAll.VB_Description = "Removes all Widgets in the collection." Set this.Collection = New Collection Set this.Keys = New Scripting.Dictionary End Sub Public Function Keys() As Variant Attribute Keys.VB_Description = "Returns a Variant array of the Widget IDs in the collection." Keys = this.Keys.Keys End Function Private Function IsLongInteger(ByVal Expression As Variant) As Boolean Attribute IsLongInteger.VB_Description = "Private helper to see if a key is a numeric index." IsLongInteger = False If IsNumeric(Expression) Then If CLng(Expression) = Expression Then IsLongInteger = True Exit Function End If End If End Function
Widget upon Widget
And putting it to use:
Sub foo() Dim coll As Widgets Dim widg As Widget Set coll = New Widgets coll.Add coll.CreateWidget("ABC", "ABC Widget", Now()) coll.Add coll.CreateWidget("BCD", "BCD Widget", Now()) coll.Add coll.CreateWidget("CDE", "CDE Widget", Now()) coll.Add coll.CreateWidget("DEF", "DEF Widget", Now()) 'Enumerate the collection For Each widg In coll Debug.Print widg.Name Next 'Check a Widget exists by ID If coll.Exists("DEF") Then Debug.Print coll("DEF").ReleaseDate End If 'Remove by 0-based index coll.Remove 0 'Remove by Widget ID coll.Remove "DEF" 'Enumerate the collection For Each widg In coll Debug.Print widg.ID Next End Sub
ABC Widget BCD Widget CDE Widget DEF Widget 23/02/2017 3:10:45 PM BCD CDE
I've sacrificed a few features of Collection (like being able to add a Widget before or after an existing collection key), and I haven't honored the CompareMethod of a Dictionary, but these are easily added.
Have I missed anything? Am I missing some performance tweaks?
For Each widg in colldoesn't seem to work for me. I would have to
For i = Base To coll.Count Set widg = coll.Item(i). I also had to enable scripting runtime. \$\endgroup\$
Microsoft Scripting Runtimeis required, but as long as the module texts are imported into the VBE, the
For Eachfunctionality should work (the attributes are only persisted if they're imported). Just tried it on a second PC, and it works for me™ \$\endgroup\$
Attributesin, it won't compile for me. I'm doing something wrong, right? \$\endgroup\$
.clsand then import file - now it works fine. \$\endgroup\$