UtterAccess HomeUtterAccess Wiki

Welcome Guest ( Log In | Register )

Custom Search
Edit Discussion
> Collection Class    
Collection Class

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.

You can download the class here: CollectionWrapper.zip or copy and past the code below into a text file, save, and then rename the file with the .cls extension. Then in the VB editor, go to File, Import File..

Examples

Here are a few examples for using the collection class with objects and non-object items.

CODE

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.

CODE

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


Creative Commons License
Collection Class by UtterAccess Wiki is licensed under a Creative Commons Attribution-ShareAlike 3.0 Unported License.
Editing and revision of the content is freely encouraged; for details, see Expected Usage.

Edit Discussion
Custom Search
Thank you for your support!
This page has been accessed 6,960 times.  This page was last modified 09:37, 25 October 2017 by Jaiket. Contributions by jamiew  Disclaimers