Enumerable Custom Collections in VBA with Dictionary features like Exists

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 bonu

Some comments:

• 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.

• While we're looking at IsLongInteger, what happens if I pass in the string "4"?

• Why the pImpl–like approach where you declare a Type inside a Class?

• Requiring the member class to have a .Self property is a code smell.

• Why is every property on Widget mutable?

• Exit Property is not needed after Err.Raise.

• 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  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

StackExchange Code Review Q#156070, answer score: 4