Collection extended: find out keys of a Collection

For quite a while there has been code for finding out Collection keys posted over at Planet Source Code. The problem with this code is that it is slow: having a loop with API calls is not the fastest thing to do, so there obviously was room for improvement.

Here I introduce two separate solutions: a module with three methods to work with existing Collections, and a class module that gives a slightly more OOP feel and possibly easier access, but is slightly slower to access as it is one additional layer more (that one could consider unnecessary).

Here is the module code:

Code:

---

' Collection extension module by Merri
' Based on information found at http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=68075&lngWId=1
Option Explicit

Private Declare Function ArrayPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
Private Declare Function lstrcmpiW Lib "kernel32" (ByVal Str1 As Long, ByVal Str2 As Long) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long

Public Function GetColIndex(Collection As Collection, Key As String) As Long
    Dim lngCurPtr As Long, lngHeader(5) As Long, lngKeyPtr As Long, lngLenB As Long, lngPtr() As Long, lngStrPtr As Long
    If Not Collection Is Nothing Then
        If LenB(Key) Then
            ' remember the StrPtr for fast access
            lngKeyPtr = StrPtr(Key)
            ' we do not want to have API calls in a loop because they're slow
            ' we can avoid that by faking a safe array to our liking!
            lngHeader(0) = 1 ' dimensions
            lngHeader(1) = 4 ' bytes per item
            lngHeader(4) = 1 ' number of items
            ' put lngPtr array into our control
            PutMem4 ArrayPtr(lngPtr), VarPtr(lngHeader(0))
            ' starting pointer: we trick to begin from the last item
            lngCurPtr = ObjPtr(Collection) + 8
            ' and then we loop...
            For GetColIndex = Collection.Count To 1 Step -1
                ' pointer change: get previous item
                lngHeader(3) = lngCurPtr + 20
                ' remember current pointer
                lngCurPtr = lngPtr(0)
                ' pointer change: get string pointer
                lngHeader(3) = lngCurPtr + 16
                ' compare for equality
                If lngPtr(0) Then If lstrcmpiW(lngPtr(0), lngKeyPtr) = 0 Then Exit For
            Next GetColIndex
            ' we are done with that trick, reset lngPtr to null
            PutMem4 ArrayPtr(lngPtr), 0
        End If
    Else
        ' No Object
        Err.Raise 91
    End If
End Function

Public Function GetColKey(Collection As Collection, ByVal Index As Long) As String
    Dim lngA As Long, lngHeader(5) As Long, lngLenB As Long, lngPtr() As Long, lngStrPtr As Long
    If Not Collection Is Nothing Then
        If Index >= 1 And Index <= Collection.Count Then
            ' we do not want to have API calls in a loop because they're slow
            ' we can avoid that by faking a safe array to our liking!
            lngHeader(0) = 1 ' dimensions
            lngHeader(1) = 4 ' bytes per item
            lngHeader(4) = 1 ' number of items
            ' put lngPtr array into our control
            PutMem4 ArrayPtr(lngPtr), VarPtr(lngHeader(0))
            ' we have to loop...
            If Index < Collection.Count \ 2 Then
                ' pointer change: get first item
                lngHeader(3) = ObjPtr(Collection) + 24
                ' loop from beginning to end
                For lngA = 2 To Index
                    ' pointer change: get next item
                    lngHeader(3) = lngPtr(0) + 24
                Next lngA
            Else
                ' pointer change: get last item
                lngHeader(3) = ObjPtr(Collection) + 28
                ' loop from end to beginning
                For lngA = Collection.Count - 1 To Index Step -1
                    ' pointer change: get previous item
                    lngHeader(3) = lngPtr(0) + 20
                Next lngA
            End If
            ' now figure out the StrPtr
            lngHeader(3) = lngPtr(0) + 16
            lngStrPtr = lngPtr(0)
            ' now figure out the string length IF we have a string
            If lngStrPtr Then
                lngHeader(3) = lngStrPtr - 4
                lngLenB = lngPtr(0)
                ' and now create a new string and place it to output
                PutMem4 VarPtr(GetColKey), SysAllocStringByteLen(lngStrPtr, lngLenB)
            End If
            ' we are done with that trick, reset lngPtr to null
            PutMem4 ArrayPtr(lngPtr), 0
        Else
            ' Index Out Of Range
            Err.Raise 9
        End If
    Else
        ' No Object
        Err.Raise 91
    End If
End Function

Public Sub GetColKeys(Collection As Collection, StringArray() As String)
    Dim lngA As Long, lngCount As Long, lngCurPtr As Long, lngKeyPtr As Long, lngHeader(5) As Long, lngLenB As Long, lngPtr() As Long, lngStrPtr As Long
    ' ensure the array is uninitialized
    If Not Not StringArray Then Erase StringArray
    Debug.Assert App.hInstance
    ' shortest way to see whether Erase worked or not (can't Erase fixed size arrays)
    If Not Not StringArray Then Exit Sub
    Debug.Assert App.hInstance
    If Not Collection Is Nothing Then
        If Collection.Count Then
            ' reserve maximum amount of results
            ReDim StringArray(0 To Collection.Count - 1)
            ' remember the pointer of first item for fast access
            lngKeyPtr = VarPtr(StringArray(0))
            ' we do not want to have API calls in a loop because they're slow
            ' we can avoid that by faking a safe array to our liking!
            lngHeader(0) = 1 ' dimensions
            lngHeader(1) = 4 ' bytes per item
            lngHeader(4) = 1 ' number of items
            ' put lngPtr array into our control
            PutMem4 ArrayPtr(lngPtr), VarPtr(lngHeader(0))
            ' starting pointer
            lngCurPtr = ObjPtr(Collection)
            ' and then we loop...
            For lngA = 1 To Collection.Count
                ' pointer change: get next item
                lngHeader(3) = lngCurPtr + 24
                ' remember current pointer
                lngCurPtr = lngPtr(0)
                ' pointer change: get string pointer
                lngHeader(3) = lngCurPtr + 16
                ' see if we add it in
                lngStrPtr = lngPtr(0)
                If lngStrPtr Then
                    ' get string length
                    lngHeader(3) = lngStrPtr - 4
                    lngLenB = lngPtr(0)
                    ' store a new string to output string array
                    PutMem4 lngKeyPtr, SysAllocStringByteLen(lngStrPtr, lngLenB)
                    ' jump to next output string array item and increase counter
                    lngKeyPtr = lngKeyPtr + 4
                    lngCount = lngCount + 1
                End If
            Next lngA
            ' we are done with that trick, reset lngPtr to null
            PutMem4 ArrayPtr(lngPtr), 0
        End If
        If lngCount = 0 Then
            ' return an empty initialized string array
            StringArray = Split(vbNullString)
        ElseIf lngCount < Collection.Count Then
            ' remove unused items
            ReDim Preserve StringArray(lngCount - 1)
        End If
    Else
        ' No Object
        Err.Raise 91
    End If
End Sub

---

The class module requires other changes to be done than just pasting the code, so you can find that one in the attachment.


Usage of module
Three new methods are introduced:

GetColIndex(Collection As Collection, Key As String) As Long
Returns index for given Key, or 0 if Key was not found.

GetColKey(Collection As Collection, ByVal Index As Long) As String
Returns Key for given Index, or a null string if no Key is assigned to the item.

GetColKeys(Collection As Collection, StringArray() As String)
Returns an array of Keys in the given string array. Only Keys that exist are returned. If no Key was found the array is initialized, but empty (read: you can use LBound & UBound safely).


Usage of class module
Four new methods are introduced: Clear, Index, Key, Keys

• Clear cleans up the collection
• Index returns the Index of given Key, or 0 if Key was not found
• Key returns the Key of given Index, or null string if Key has not been assigned to the item
• Keys fills the given string array with Keys that exist in the collection

Here is a sample:

Code:

---

Option Explicit

Private Sub Form_Load()
    Dim Moron As New Collection, strKeys() As String
    Moron.Add "Why", "I"
    Moron.Add "Would", "Know"
    Moron.Add "That", "My"
    Moron.Add "Advanced", "Stuff"
    Moron.Add "Rocks?"
    GetColKeys Moron, strKeys
    MsgBox Join(strKeys)
    MsgBox Moron(GetColIndex(Moron, "know")) & " " & GetColKey(Moron, 1) & " " & GetColKey(Moron, 4) & " " & Moron(GetColIndex(Moron, "my"))
End Sub

---

Here is an extension to the module: SetColItem. It lets you change a Collection item without removing it first.

Code:

---

Public Sub SetColItem(Collection As Collection, NewItem, Optional ByVal Index As Long, Optional Key As String)
    Dim lngA As Long, lngCurPtr As Long, lngHeader(5) As Long, lngKeyPtr As Long, lngPtr() As Long, lngVarHead(5) As Long, varArray()
    If Not Collection Is Nothing Then
        ' now have a go at this...
        If (LenB(Key) > 0) Or (Index >= 1 And Index <= Collection.Count) Then
            ' we do not want to have API calls in a loop because they're slow
            ' we can avoid that by faking a safe array to our liking!
            lngHeader(0) = 1 ' dimensions
            lngHeader(1) = 4 ' bytes per item
            lngHeader(4) = 1 ' number of items
            ' put lngPtr array into our control
            PutMem4 ArrayPtr(lngPtr), VarPtr(lngHeader(0))
            ' we have to loop...
            If LenB(Key) Then
                ' work on key
                lngKeyPtr = StrPtr(Key)
                ' starting pointer: we trick to begin from the last item
                lngCurPtr = ObjPtr(Collection) + 8
                ' and then we loop...
                For Index = Collection.Count To 1 Step -1
                    ' pointer change: get previous item
                    lngHeader(3) = lngCurPtr + 20
                    ' remember current pointer
                    lngCurPtr = lngPtr(0)
                    ' pointer change: get string pointer
                    lngHeader(3) = lngCurPtr + 16
                    ' compare for equality
                    If lngPtr(0) Then If lstrcmpiW(lngPtr(0), lngKeyPtr) = 0 Then Exit For
                Next Index
            Else
                ' work on index
                If Index < Collection.Count \ 2 Then
                    ' pointer change: get first item
                    lngHeader(3) = ObjPtr(Collection) + 24
                    ' loop from beginning to end
                    For lngA = 2 To Index
                        ' pointer change: get next item
                        lngHeader(3) = lngPtr(0) + 24
                    Next lngA
                Else
                    ' pointer change: get last item
                    lngHeader(3) = ObjPtr(Collection) + 28
                    ' loop from end to beginning
                    For lngA = Collection.Count - 1 To Index Step -1
                        ' pointer change: get previous item
                        lngHeader(3) = lngPtr(0) + 20
                    Next lngA
                End If
                lngCurPtr = lngPtr(0)
            End If
            ' if Index is set then we can go on
            If Index Then
                ' the cool stuff continues: now we create a Variant array
                lngVarHead(0) = 1
                lngVarHead(1) = 16
                lngVarHead(3) = lngCurPtr
                lngVarHead(4) = 1
                PutMem4 ArrayPtr(varArray), VarPtr(lngVarHead(0))
                ' then we do just the simplest thing of replacing a Variant with another...
                If VarType(NewItem) <> vbObject Then
                    varArray(0) = NewItem
                Else
                    Set varArray(0) = NewItem
                End If
                PutMem4 ArrayPtr(varArray), 0
            End If
            ' we are done with that trick, reset lngPtr to null
            PutMem4 ArrayPtr(lngPtr), 0
        Else
            ' Index Out Of Range
            Err.Raise 9
        End If
    Else
        ' No Object
        Err.Raise 91
    End If
End Sub

---

Probably not one of the most useful things out there, but this brings out a new possible idea: a CollectionToArray converter method that could return a Variant array with the items and a String array with keys, and which efficiently clears up the Collection as it goes. Although I don't know what a Collection would like if it had just null items before being destroyed, but I guess that is something I'll just see if I bother with this.


... and by going further, by having such arrays it would be easily possible to make a sorter that would sort Collection items by their respective key! Sorting the actual items makes no sense since a Collection item can be anything, and that makes it unsortable. The keys are sortable as they're always strings.