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 propertyExists
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. AWidget
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?
For Each widg in coll
doesn't seem to work for me. I would have toFor i = Base To coll.Count Set widg = coll.Item(i)
. I also had to enable scripting runtime. \$\endgroup\$Microsoft Scripting Runtime
is required, but as long as the module texts are imported into the VBE, theFor Each
functionality should work (the attributes are only persisted if they're imported). Just tried it on a second PC, and it works for me™ \$\endgroup\$Attributes
in, it won't compile for me. I'm doing something wrong, right? \$\endgroup\$.cls
and then import file - now it works fine. \$\endgroup\$