CollectionWrapper Class Summary
This Visual Basic Collection Class is a wrapper for the collection object in VBA and allows for additional functionality than what is offered by using a collection object by itself. As it is setup currently, this class is not strongly typed, meaning that you could add a bunch of strings, numerics, or objects to it. This may be the desired result, or you may choose to modify it to only deal with one specific object or variable type. To do this, change the Add method and Item property from Variant to the variable of object type of your choosing.
Examples
Here are a few examples for using the collection class with objects and non-object items.
Public Sub AddItemsToCollection()
Dim Students As CollectionWrapper
Set Students = New CollectionWrapper
Students.Add "Bobby", "Bobby"
Students.Add "Sara", "Sara"
Students.Add "Ricky", "Ricky"
Students.Add "Christina", "Christina", "Sara" ' Put Christina before Sara.
Students.Add "Martha", "Martha", , "Christina" ' Put Martha in after Christina.
Dim Student As Variant
For Each Student In Students
Debug.Print Student
Next Student
' Will Output the following:
' Bobby
' Christina
' Martha
' Sara
' Ricky
End Sub
Public Sub GetItemsFromCollection()
Dim Students As CollectionWrapper
Set Students = New CollectionWrapper
Students.Add "Bobby", "Bobby"
Students.Add "Sara", "Sara"
Students.Add "Ricky", "Ricky"
Students.Add "Christina", "Christina", "Sara" ' Put Christina before Sara.
Students.Add "Martha", "Martha", , "Christina" ' Put Martha in after Christina.
' Get the first item in the Collection.
Debug.Print Students.First
'Get the last item in the Collection.
Debug.Print Students.Last
' Get an Item using the Item property.
Debug.Print Students.Item("Sara") ' Referencing by key.
Debug.Print Students.Item(2) ' Reference by index.
' Still using the Item property, but as the default
' member of this CollectionWrapper class.
Debug.Print Students("Sara")
Debug.Print Students(2)
' Get all of the Items using For...Each syntax.
Dim Student As Variant
For Each Student In Students
Debug.Print Student
Next Student
End Sub
Public Sub ObjectExample()
Dim MyCars As New CollectionWrapper
Dim Mustang As Car
Set Mustang = New Car
Mustang.Color = "Blue"
MyCars.Add Mustang
For Each Mustang In MyCars
Debug.Print Mustang.Color
Next Mustang
End Sub
Installation
Copy the code below into a .cls file and import into the VBA editor.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CollectionWrapper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Description = "A Visual Basic Collection is an ordered set of items that can be referred to as a unit."
'---------------------------------------------------------------------------------------
' Module : CollectionWrapper Class
' Author : Jamie West
' Summary : A Visual Basic Collection is an ordered set of items that can be
' referred to as a unit.
'---------------------------------------------------------------------------------------
'
Option Compare Text
Option Explicit
Private m_col As Collection
Public Function Add(Item As Variant, _
Optional Key As String, _
Optional Before As Variant, _
Optional After As Variant) As Boolean
Attribute Add.VB_Description = "Adds an element to a Collection object."
'---------------------------------------------------------------------------------------
' Procedure : Add
' Purpose : Adds an element to a Collection object.
'---------------------------------------------------------------------------------------
'
On Error GoTo Error_Handler
If Not Len(Key) = 0 Then
m_col.Add Item, Key, Before, After
Else
m_col.Add Item, , Before, After
End If
Add = True
Exit_Handler:
Exit Function
Error_Handler:
If Err.Number = 457 Then
Add = False
End If
Resume Exit_Handler
End Function
Private Sub Class_Initialize()
Attribute Class_Initialize.VB_Description = "Creates a new instance of this CollectionWrapper class."
'---------------------------------------------------------------------------------------
' Procedure : Class_Initialize
' Purpose : Creates a new instance of this CollectionWrapper class.
'---------------------------------------------------------------------------------------
'
Set m_col = New Collection
End Sub
Private Sub Class_Terminate()
Attribute Class_Terminate.VB_Description = "Destructs this current instance."
'---------------------------------------------------------------------------------------
' Procedure : Class_Terminate
' Purpose : Destructs this current instance.
'---------------------------------------------------------------------------------------
'
Set m_col = Nothing
End Sub
Public Sub Clear()
Attribute Clear.VB_Description = "Deletes all elements of a Visual Basic Collection object."
'---------------------------------------------------------------------------------------
' Procedure : Clear
' Purpose : Deletes all elements of a Visual Basic Collection object.
'---------------------------------------------------------------------------------------
'
Set m_col = New Collection
End Sub
Public Function Contains(Key As Variant) As Boolean
Attribute Contains.VB_Description = "Returns a Boolean value indicating whether a Visual Basic Collection object contains an element with a specific key."
'---------------------------------------------------------------------------------------
' Procedure : Contains
' Purpose : Returns a Boolean value indicating whether a Visual Basic Collection
' object contains an element with a specific key.
'---------------------------------------------------------------------------------------
'
Dim Item As Variant
On Error GoTo Error_Handler
If IsObject(m_col.Item(Key)) Then
Set Item = m_col.Item(Key)
Else
Item = m_col.Item(Key)
End If
Contains = True
Exit_Function:
Set Item = Nothing
Exit Function
Error_Handler:
If Err.Number = 5 Then
Contains = False
Else
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical
End If
Resume Exit_Function
End Function
Public Function CopyTo(ToArray As Variant, Index As Integer) As Boolean
Attribute CopyTo.VB_Description = "Copies the elements of the Collection to an Array, starting at a particular Array index."
'---------------------------------------------------------------------------------------
' Procedure : CopyTo
' Purpose : Copies the elements of the ICollection to an Array, starting at a
' particular Array index.
'---------------------------------------------------------------------------------------
'
Dim Position As Integer
If m_col Is Nothing Then
Exit Function
End If
If Not IsArray(ToArray) Then
Exit Function
End If
If Not IsArrayDynamic(ToArray) Then
Exit Function
End If
If Me.Count < 1 Then
Exit Function
End If
ReDim ToArray(Index To Me.Count)
For Position = Index To Me.Count
If IsObject(m_col(Position)) Then
Set ToArray(Position) = m_col(Position)
Else
ToArray(Position) = m_col(Position)
End If
Next Position
CopyTo = True
End Function
Public Property Get Count() As Integer
Attribute Count.VB_Description = "Returns an Integer containing the number of elements in a collection. Read-only."
'---------------------------------------------------------------------------------------
' Procedure : Count
' Purpose : Returns an Integer containing the number of elements in a collection.
' Read-only.
'---------------------------------------------------------------------------------------
'
Count = m_col.Count
End Property
Public Function First() As Variant
Attribute First.VB_Description = "Retrieves the first Item in this collection."
'---------------------------------------------------------------------------------------
' Procedure : First
' Purpose : Retrieves the first Item in this collection.
'---------------------------------------------------------------------------------------
'
If Me.Count > 0 Then
If IsObject(m_col.Item(1)) Then
Set First = m_col.Item(1)
Else
First = m_col.Item(1)
End If
End If
End Function
Public Property Get GetEnumerator() As IUnknown
Attribute GetEnumerator.VB_Description = "Returns a reference to an enumerator object, which is used to iterate over a Collection object."
Attribute GetEnumerator.VB_UserMemId = -4
'---------------------------------------------------------------------------------------
' Procedure : NewEnum Property
' Purpose : Property that allows enumeration through the collection using
' For...Each syntax.
' Requires : Attribute NewEnum.VB_UserMemId = -4
'---------------------------------------------------------------------------------------
'
Set GetEnumerator = m_col.[_NewEnum]
End Property
Private Function IsArrayDynamic(ByRef Value As Variant) As Boolean
Attribute IsArrayDynamic.VB_Description = "Returns whether an Array is dynamic or not."
'---------------------------------------------------------------------------------------
' Procedure : IsArrayDynamic
' Purpose : Returns whether an Array is dynamic or not.
' Source : http://www.cpearson.com/excel/vbaarrays.htm
'---------------------------------------------------------------------------------------
'
Dim OriginalUpperBound As Long
' If we weren't passed an array, get out now with a FALSE result
If IsArray(Value) = False Then
IsArrayDynamic = False
Exit Function
End If
' If the array is empty, it hasn't been allocated yet, so we know
' it must be a dynamic array.
If IsArrayEmpty(Value) = True Then
IsArrayDynamic = True
Exit Function
End If
' Save the UBound of Arr.
' This value will be used to restore the original UBound if Arr
' is a single-dimensional dynamic array. Unused if Arr is multi-dimensional,
' or if Arr is a static array.
OriginalUpperBound = UBound(Value)
On Error Resume Next
Err.Clear
ReDim Preserve Value(LBound(Value) To OriginalUpperBound + 1)
Select Case Err.Number
Case 0
ReDim Preserve Value(LBound(Value) To OriginalUpperBound)
IsArrayDynamic = True
Case 9
IsArrayDynamic = True
Case 10
IsArrayDynamic = False
Case Else
IsArrayDynamic = False
End Select
End Function
Private Function IsArrayEmpty(Value As Variant) As Boolean
Attribute IsArrayEmpty.VB_Description = "Returns whether or not an Array is empty."
'---------------------------------------------------------------------------------------
' Procedure : IsArrayEmpty
' Purpose : Returns whether or not an Array is empty.
' Source : http://www.cpearson.com/excel/vbaarrays.htm
'---------------------------------------------------------------------------------------
'
Dim LowerBound As Long
Dim UpperBound As Long
Err.Clear
On Error Resume Next
If Not IsArray(Value) Then
' we weren't passed an array, return True
IsArrayEmpty = True
End If
' Attempt to get the UBound of the array. If the array is
' unallocated, an error will occur.
UpperBound = UBound(Value, 1)
If (Err.Number <> 0) Then
IsArrayEmpty = True
Else
Err.Clear
LowerBound = LBound(Value)
If LowerBound > UpperBound Then
IsArrayEmpty = True
Else
IsArrayEmpty = False
End If
End If
End Function
Public Property Get Item(Key As Variant) As Variant
Attribute Item.VB_Description = "Returns a specific element of a Collection object either by position or by key. Read-only."
Attribute Item.VB_UserMemId = 0
'---------------------------------------------------------------------------------------
' Procedure : Item
' Purpose : Returns a specific element of a Collection object either by position
' or by key. Read-only.
' Requires : Attribute Item.VB_UserMemId = 0
'---------------------------------------------------------------------------------------
'
If Contains(Key) Then
If IsObject(m_col.Item(Key)) Then
Set Item = m_col.Item(Key)
Else
Item = m_col.Item(Key)
End If
End If
End Property
Public Function Last() As Variant
Attribute Last.VB_Description = "Retrieves the last Item in this Collection."
'---------------------------------------------------------------------------------------
' Procedure : Last
' Purpose : Retrieves the last Item in this Collection.
'---------------------------------------------------------------------------------------
'
If Me.Count > 0 Then
If IsObject(m_col.Item(Me.Count)) Then
Set Last = m_col.Item(Me.Count)
Else
Last = m_col.Item(Me.Count)
End If
End If
End Function
Public Function OfType(Name As String) As Variant
Attribute OfType.VB_Description = "Returns Items within a Collection that match a specific TypeName."
'---------------------------------------------------------------------------------------
' Procedure : OfType
' Purpose : Returns Items within a Collection that match a specific TypeName.
'---------------------------------------------------------------------------------------
'
Dim Item As Variant
Dim Types As New Collection
For Each Item In Me
If TypeName(Item) = Name Then
Types.Add Item
End If
Next Item
If Types.Count <> 0 Then
Set OfType = Types
End If
End Function
Public Function Remove(Key As Variant) As Boolean
Attribute Remove.VB_Description = "Removes an element from a Collection object."
'---------------------------------------------------------------------------------------
' Procedure : Remove
' Purpose : Removes an element from a Collection object.
'---------------------------------------------------------------------------------------
'
If Contains(Key) Then
m_col.Remove Key
Remove = True
End If
End Function