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?

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