Enumerable Custom Collections in VBA with Dictionary features like Exists

Question

To Collect or Hash

The 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 Exists and 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 Item method
• Item method is default member, and it's a property
• Exists method for membership checks
• Enumerable
• 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 Widget

First, we need a class for the objects that we'll put into our custom collection. A Widget will 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

Output:

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?

• Raystafarian: For Each widg in coll doesn'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.
• ThunderFrame: Yes, a reference to Microsoft Scripting Runtime is required, but as long as the module texts are imported into the VBE, the For Each functionality should work (the attributes are only persisted if they're imported). Just tried it on a second PC, and it works for meTM
• Raystafarian: Leaving the Attributes in, it won't compile for me. I'm doing something wrong, right?
• Raystafarian: Ah, I had to take the text, put it in a text file, save as .cls and then import file - now it works fine.
• Raystafarian: What do you mean by "interface"?

Answer 1

Some comments:

1. Why all the VB_Description attributes? An average user of your class will be doing everything through the VBE, and so won't see those unless she opens Object Browser. And for private members like IsLongInteger, not even that is possible.
2. While we're looking at IsLongInteger, what happens if I pass in the string "4"?
3. Why the pImpl–like approach where you declare a Type inside a Class?
4. Requiring the member class to have a .Self property is a code smell.
5. Why is every property on Widget mutable?
6. Exit Property is not needed after Err.Raise.
7. Consider extracting a private method to handle the repeated "ID or index?" logic.

I might reïmplement like this.

Widget.cls:

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 m_ID As String
Private m_Name As String
Private m_ReleaseDate As Date
Public Property Get ID() As String
Attribute ID.VB_UserMemId = 0
 ID = m_ID
End Property
Public Property Get Name() As String
 Name = m_Name
End Property
Public Property Get ReleaseDate() As Date
 ReleaseDate = m_ReleaseDate
End Property
Public Sub Setup(ID As String, Name As String, ByVal ReleaseDate As Date)
' ID must be a unique identifier
 m_ID = ID
 m_Name = Name
 m_ReleaseDate = ReleaseDate
End Sub

Widgets.cls:

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 Const BASE_INDEX As Long = 0
Private m_coll As Collection
Private m_dict As Dictionary
Private Sub Class_Initialize()
 Set m_coll = New Collection
 Set m_dict = New Dictionary
End Sub
Public Property Get Item(IDOrIndex As Variant) As Widget
Attribute Item.VB_UserMemId = 0
 Set Item = m_coll.Item(GetBase1Index(IDOrIndex))
End Property
Public Sub Add(Widget As Widget)
 Dim Key As String
 Key = Widget.ID
 If Not m_dict.Exists(Key) Then
 m_coll.Add Widget, Key
 m_dict.Add Key, m_coll.Count
 Else
 Err.Raise 457, "Widget.Add", "The key '" & Key & "' is already associated with an element of this collection"
 End If
End Sub
Property Get Count() As Long
 Count = m_dict.Count
End Property
Public Function CreateWidget(ID As String, Name As String, ByVal ReleaseDate As Date) As Widget
 Set CreateWidget = New Widget
 CreateWidget.Setup ID, Name, ReleaseDate
End Function
Public Function Exists(ID As String) As Boolean
 Exists = m_dict.Exists(ID)
End Function
Public Function Keys() As Variant
 Keys = m_dict.Keys
End Function
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
 Set NewEnum = m_coll.[_NewEnum]
End Function
Public Sub Remove(IDOrIndex As Variant)
 Dim Base1Index As Long, ID As String
 Base1Index = GetBase1Index(IDOrIndex)
 ID = m_coll(Base1Index).ID
 m_coll.Remove Base1Index
 m_dict.Remove ID
 ' now decrement the indexes for all subsequent keys
 Dim nextkey As String, NextBase0Index As Long
 For NextBase0Index = Base1Index - 1 To m_dict.Count - 1
 nextkey = m_dict.Keys(NextBase0Index)
 m_dict.Item(nextkey) = NextBase0Index + 1
 Next NextBase0Index
End Sub
Public Sub RemoveAll()
 Set m_coll = New Collection
 Set m_dict = New Dictionary
End Sub
Private Function GetBase1Index(IDOrIndex As Variant) As Long
 If IsLongOrInteger(IDOrIndex) Then
 ' numeric index
 GetBase1Index = IDOrIndex + 1 - BASE_INDEX
 ElseIf m_dict.Exists(IDOrIndex) Then
 ' ID code
 GetBase1Index = m_dict(IDOrIndex)
 Else
 Err.Raise 9, "Widgets.Item", "ID '" & IDOrIndex & "' is out of range."
 End If
 If GetBase1Index < 1 Or GetBase1Index > m_coll.Count Then
 Err.Raise 9, "Widget.Item", "Index " & IDOrIndex & " is out of range. Widgets is " & BASE_INDEX & "-based"
 End If
End Function
Private Function IsLongOrInteger(Expression As Variant) As Boolean
 IsLongOrInteger = VarType(Expression) = vbLong Or VarType(Expression) = vbInteger
End Function

• ThunderFrame: Description attributes are still useful, even in the OB, but I didn't realize the Private members wouldn't show their descriptions. 2. IsLongInteger doesn't care if it implicitly casts "4" to 4, if "4" was a key, its existence was already checked before IsLongInteger was called. 3. The Type is for concise definitions of fields that allow the public property and the private field to have the same name. Anywhere I use this, I know I'm using a field, and I avoid m_ hungarian. It also makes for easy serialization, if needed. 4. Selfis smelly, but convenient.
• ThunderFrame: 5. All properties are utable because this class is MCVE and a generic example. Real implementations would differ. 6. Indeed, Exit Function is overkill and redundant. 7. I like the private method for determining the index/key - I was worried I'd missed an edge-case, but implementing the logic a single time is a desirable and necessary refactor.
• Mathieu Guindon: @Chel I'd suggest you read this article I wrote about OOP code in VBA. It touches on the Private Type approach and the .Self member - although the setters (Property Let) are Public for simplicity, in an add-in/library they would be Friend members (including the .Self getter), which effectively makes the instance immutable as far as client code is concerned. The .Self is only there to enable implementing the factory method with a convenient With block; it avoids needing a local variable.
• ThunderFrame: @Mat'sMug I know, but this question is primarily about the Collection class. The Widget was just a strongly typed something to put into the Collection. The Collection is real and complete code - it's just specific to collecting widgets in this post, but can be changed to collect any class.
• Mathieu Guindon: FYI the latest Rubberduck build uses VB_Description attributes to display an info label when a call site is selected, and lets you use '@Description("whatever") annotations (/magic comments) to tell Rubberduck to insert a VB_Description attribute to a given procedure, so the statement about them being only visible in the object browser isn't really true anymore ;-)