[VB6/VBA] Collection keys

mdCollection.bas

Option Explicit

#Const HasPtrSafe = (VBA7 <> 0)
#Const LargeAddressAware = (Win64 = 0 And VBA7 = 0 And VBA6 = 0 And VBA5 = 0)

'--- for CopyMemory
#If HasPtrSafe Then
    Private Const NULL_PTR                  As LongPtr = 0
#Else
    Private Const NULL_PTR                  As Long = 0
#End If
#If Win64 Then
    Private Const PTR_SIZE                  As Long = 8
#Else
    Private Const PTR_SIZE                  As Long = 4
    Private Const SIGN_BIT                  As Long = &H80000000
#End If
'--- for CompareStringW
Private Const LOCALE_USER_DEFAULT           As Long = &H400
Private Const NORM_IGNORECASE               As Long = 1
Private Const CSTR_LESS_THAN                As Long = 1
Private Const CSTR_EQUAL                    As Long = 2
Private Const CSTR_GREATER_THAN             As Long = 3

#If HasPtrSafe Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function CompareStringW Lib "kernel32" (ByVal Locale As Long, ByVal dwCmpFlags As Long, lpString1 As Any, ByVal cchCount1 As Long, lpString2 As Any, ByVal cchCount2 As Long) As Long
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function CompareStringW Lib "kernel32" (ByVal Locale As Long, ByVal dwCmpFlags As Long, lpString1 As Any, ByVal cchCount1 As Long, lpString2 As Any, ByVal cchCount2 As Long) As Long
#End If

#If Win64 Then
    Private Type VbCollectionHeader
        pInterface1         As LongPtr  '  &H00
        pInterface2         As LongPtr  '  &H08
        pInterface3         As LongPtr  '  &H10
        lRefCounter         As Long     '  &H18
        Count               As Long     '  &H1C
        pvUnk1              As LongPtr  '  &H20
        pFirstIndexedItem   As LongPtr  '  &H28
        pLastIndexedItem    As LongPtr  '  &H30
        pvUnk4              As LongPtr  '  &H38
        pRootTreeItem       As LongPtr  '  &H40
        pEndTreePtr         As LongPtr  '  &H48
        pvUnk5              As LongPtr  '  &H50
    End Type                            '  &H58
    
    Private Type VbCollectionItem
        Data                As Variant  '  &H00
        KeyPtr              As LongPtr  '  &H18
        pPrevIndexedItem    As LongPtr  '  &H20
        pNextIndexedItem    As LongPtr  '  &H28
    '    pvUnknown           As LongPtr
        pParentItem         As LongPtr  '  &H30
        pRightBranch        As LongPtr  '  &H38
        pLeftBranch         As LongPtr  '  &H40
        bFlag               As Boolean  '  &H48
    End Type                            '  &H4C
    
    Private Enum VbCollectionOffsets
        o_pFirstIndexedItem = &H28
        o_pRootTreeItem = &H40
        o_pEndTreePtr = &H48
        '--- item
        o_KeyPtr = &H18
        o_pNextIndexedItem = o_pFirstIndexedItem '--- Coincidence?
        o_pRightBranch = &H38
        o_pLeftBranch = &H40
    End Enum
#Else
    Private Type VbCollectionHeader
        pInterface1         As Long   '  &H00
        pInterface2         As Long   '  &H04
        pInterface3         As Long   '  &H08
        lRefCounter         As Long   '  &H0C
        Count               As Long   '  &H10
        pvUnk1              As Long   '  &H14
        pFirstIndexedItem   As Long   '  &H18
        pLastIndexedItem    As Long   '  &H1C
        pvUnk4              As Long   '  &H20
        pRootTreeItem       As Long   '  &H24
        pEndTreePtr         As Long   '  &H28
        pvUnk5              As Long   '  &H2C
    End Type                          '  &H30
    
    Private Type VbCollectionItem
        Data                As Variant  '  &H00
        KeyPtr              As Long     '  &H10
        pPrevIndexedItem    As Long     '  &H14
        pNextIndexedItem    As Long     '  &H18
        pvUnknown           As Long     '  &H1C
        pParentItem         As Long     '  &H20
        pRightBranch        As Long     '  &H24
        pLeftBranch         As Long     '  &H28
        bFlag               As Boolean  '  &H2C
    End Type                            '  &H30
    
    Private Enum VbCollectionOffsets
        o_pFirstIndexedItem = &H18
        o_pRootTreeItem = &H24
        o_pEndTreePtr = &H28
        '--- item
        o_KeyPtr = &H10
        o_pNextIndexedItem = o_pFirstIndexedItem '--- Again?
        o_pRightBranch = &H24
        o_pLeftBranch = &H28
    End Enum
#End If

Public Function CollectionAllKeys(oCol As Collection) As String()
    #If HasPtrSafe Then
        Dim lPtr        As LongPtr
    #Else
        Dim lPtr        As Long
    #End If
    Dim aRetVal()       As String
    Dim lIdx            As Long
    Dim sTemp           As String
    
    If oCol.Count = 0 Then
        aRetVal = Split(vbNullString)
    Else
        ReDim aRetVal(1 To oCol.Count) As String
        lPtr = ObjPtr(oCol)
        For lIdx = 1 To UBound(aRetVal)
            #If LargeAddressAware Then
                Call CopyMemory(lPtr, ByVal (lPtr Xor SIGN_BIT) + o_pNextIndexedItem Xor SIGN_BIT, PTR_SIZE)
                Call CopyMemory(ByVal VarPtr(sTemp), ByVal (lPtr Xor SIGN_BIT) + o_KeyPtr Xor SIGN_BIT, PTR_SIZE)
            #Else
                Call CopyMemory(lPtr, ByVal lPtr + o_pNextIndexedItem, PTR_SIZE)
                Call CopyMemory(ByVal VarPtr(sTemp), ByVal lPtr + o_KeyPtr, PTR_SIZE)
            #End If
            aRetVal(lIdx) = sTemp
        Next
        Call CopyMemory(ByVal VarPtr(sTemp), NULL_PTR, PTR_SIZE)
    End If
    CollectionAllKeys = aRetVal
End Function

Public Function CollectionKeyByIndex(oCol As Collection, ByVal lIdx As Long) As String
    #If HasPtrSafe Then
        Dim lPtr        As LongPtr
    #Else
        Dim lPtr        As Long
    #End If
    Dim sTemp           As String
    
    If lIdx >= 1 And lIdx <= oCol.Count Then
        lPtr = ObjPtr(oCol)
        For lIdx = 1 To lIdx
            #If LargeAddressAware Then
                Call CopyMemory(lPtr, ByVal (lPtr Xor SIGN_BIT) + o_pNextIndexedItem Xor SIGN_BIT, PTR_SIZE)
            #Else
                Call CopyMemory(lPtr, ByVal lPtr + o_pNextIndexedItem, PTR_SIZE)
            #End If
        Next
        #If LargeAddressAware Then
            Call CopyMemory(ByVal VarPtr(sTemp), ByVal (lPtr Xor SIGN_BIT) + o_KeyPtr Xor SIGN_BIT, PTR_SIZE)
        #Else
            Call CopyMemory(ByVal VarPtr(sTemp), ByVal lPtr + o_KeyPtr, PTR_SIZE)
        #End If
        CollectionKeyByIndex = sTemp
        Call CopyMemory(ByVal VarPtr(sTemp), NULL_PTR, PTR_SIZE)
    End If
End Function

Public Function CollectionIndexByKey(oCol As Collection, sKey As String, Optional ByVal IgnoreCase As Boolean = True) As Long
    #If HasPtrSafe Then
        Dim lItemPtr    As LongPtr
        Dim lEofPtr     As LongPtr
        Dim lPtr        As LongPtr
    #Else
        Dim lItemPtr    As Long
        Dim lEofPtr     As Long
        Dim lPtr        As Long
    #End If
    Dim sTemp           As String
    
    If Not oCol Is Nothing Then
        #If LargeAddressAware Then
            Call CopyMemory(lItemPtr, ByVal (ObjPtr(oCol) Xor SIGN_BIT) + o_pRootTreeItem Xor SIGN_BIT, PTR_SIZE)
            Call CopyMemory(lEofPtr, ByVal (ObjPtr(oCol) Xor SIGN_BIT) + o_pEndTreePtr Xor SIGN_BIT, PTR_SIZE)
        #Else
            Call CopyMemory(lItemPtr, ByVal ObjPtr(oCol) + o_pRootTreeItem, PTR_SIZE)
            Call CopyMemory(lEofPtr, ByVal ObjPtr(oCol) + o_pEndTreePtr, PTR_SIZE)
        #End If
    End If
    Do While lItemPtr <> lEofPtr
        #If LargeAddressAware Then
            Call CopyMemory(ByVal VarPtr(sTemp), ByVal (lItemPtr Xor SIGN_BIT) + o_KeyPtr Xor SIGN_BIT, PTR_SIZE)
        #Else
            Call CopyMemory(ByVal VarPtr(sTemp), ByVal lItemPtr + o_KeyPtr, PTR_SIZE)
        #End If
        Select Case CompareStringW(LOCALE_USER_DEFAULT, -IgnoreCase * NORM_IGNORECASE, ByVal StrPtr(sKey), Len(sKey), ByVal StrPtr(sTemp), Len(sTemp))
        Case CSTR_LESS_THAN
            #If LargeAddressAware Then
                Call CopyMemory(lItemPtr, ByVal (lItemPtr Xor SIGN_BIT) + o_pLeftBranch Xor SIGN_BIT, PTR_SIZE)
            #Else
                Call CopyMemory(lItemPtr, ByVal lItemPtr + o_pLeftBranch, PTR_SIZE)
            #End If
        Case CSTR_GREATER_THAN
            #If LargeAddressAware Then
                Call CopyMemory(lItemPtr, ByVal (lItemPtr Xor SIGN_BIT) + o_pRightBranch Xor SIGN_BIT, PTR_SIZE)
            #Else
                Call CopyMemory(lItemPtr, ByVal lItemPtr + o_pRightBranch, PTR_SIZE)
            #End If
        Case CSTR_EQUAL
            lPtr = ObjPtr(oCol)
            Do While lPtr <> lItemPtr
                #If LargeAddressAware Then
                    Call CopyMemory(lPtr, ByVal (lPtr Xor SIGN_BIT) + o_pNextIndexedItem Xor SIGN_BIT, PTR_SIZE)
                #Else
                    Call CopyMemory(lPtr, ByVal lPtr + o_pNextIndexedItem, PTR_SIZE)
                #End If
                CollectionIndexByKey = CollectionIndexByKey + 1
            Loop
            GoTo QH
        Case Else
            Call CopyMemory(ByVal VarPtr(sTemp), NULL_PTR, PTR_SIZE)
            Err.Raise vbObjectError, , "Unexpected result from CompareStringW"
        End Select
    Loop
QH:
    Call CopyMemory(ByVal VarPtr(sTemp), NULL_PTR, PTR_SIZE)
End Function

Public Function CollectionSortedKeys(oCol As Collection) As String()
    #If HasPtrSafe Then
        Dim lItemPtr    As LongPtr
        Dim lEofPtr     As LongPtr
    #Else
        Dim lItemPtr    As Long
        Dim lEofPtr     As Long
    #End If
    Dim aRetVal()       As String
    Dim lCount          As Long
    
    If Not oCol Is Nothing Then
        #If LargeAddressAware Then
            Call CopyMemory(lItemPtr, ByVal (ObjPtr(oCol) Xor SIGN_BIT) + o_pRootTreeItem Xor SIGN_BIT, PTR_SIZE)
            Call CopyMemory(lEofPtr, ByVal (ObjPtr(oCol) Xor SIGN_BIT) + o_pEndTreePtr Xor SIGN_BIT, PTR_SIZE)
        #Else
            Call CopyMemory(lItemPtr, ByVal ObjPtr(oCol) + o_pRootTreeItem, PTR_SIZE)
            Call CopyMemory(lEofPtr, ByVal ObjPtr(oCol) + o_pEndTreePtr, PTR_SIZE)
        #End If
    End If
    If lItemPtr <> lEofPtr Then
        ReDim aRetVal(1 To oCol.Count) As String
        pvTraverseInorder lItemPtr, lEofPtr, aRetVal, lCount
    End If
    If lCount = 0 Then
        aRetVal = Split(vbNullString)
    ElseIf lCount < oCol.Count Then
        ReDim Preserve aRetVal(1 To lCount) As String
    End If
    CollectionSortedKeys = aRetVal
End Function
 
#If HasPtrSafe Then
Private Sub pvTraverseInorder(ByVal lItemPtr As LongPtr, ByVal lEofPtr As LongPtr, aRetVal() As String, lIdx As Long)
#Else
Private Sub pvTraverseInorder(ByVal lItemPtr As Long, ByVal lEofPtr As Long, aRetVal() As String, lIdx As Long)
#End If
    #If HasPtrSafe Then
        Dim lPtr        As LongPtr
    #Else
        Dim lPtr        As Long
    #End If
    Dim sTemp           As String
    
    '--- traverse left branch if present
    #If LargeAddressAware Then
        Call CopyMemory(lPtr, ByVal (lItemPtr Xor SIGN_BIT) + o_pLeftBranch Xor SIGN_BIT, PTR_SIZE)
    #Else
        Call CopyMemory(lPtr, ByVal lItemPtr + o_pLeftBranch, PTR_SIZE)
    #End If
    If lPtr <> lEofPtr Then
        pvTraverseInorder lPtr, lEofPtr, aRetVal, lIdx
    End If
    '--- collect current key
    #If LargeAddressAware Then
        Call CopyMemory(ByVal VarPtr(sTemp), ByVal (lItemPtr Xor SIGN_BIT) + o_KeyPtr Xor SIGN_BIT, PTR_SIZE)
    #Else
        Call CopyMemory(ByVal VarPtr(sTemp), ByVal lItemPtr + o_KeyPtr, PTR_SIZE)
    #End If
    lIdx = lIdx + 1
    aRetVal(lIdx) = sTemp
    Call CopyMemory(ByVal VarPtr(sTemp), NULL_PTR, PTR_SIZE)
    '--- traverse right branch if present
    #If LargeAddressAware Then
        Call CopyMemory(lPtr, ByVal (lItemPtr Xor SIGN_BIT) + o_pRightBranch Xor SIGN_BIT, PTR_SIZE)
    #Else
        Call CopyMemory(lPtr, ByVal lItemPtr + o_pRightBranch, PTR_SIZE)
    #End If
    If lPtr <> lEofPtr Then
        pvTraverseInorder lPtr, lEofPtr, aRetVal, lIdx
    End If
End Sub

#If False Then
Public Sub Test()
    Dim oCol As New Collection
    oCol.Add "aaaccc", "ccc"
    oCol.Add "aaaaaa", "aaa"
    oCol.Add "aaa"
    oCol.Add "aaabbb", "bbb"
    oCol.Add "test", vbNullString
    Debug.Print CollectionKeyByIndex(oCol, 1), "["; CollectionKeyByIndex(oCol, 10) & "]", StrPtr(CollectionKeyByIndex(oCol, 10))
    Debug.Print CollectionIndexByKey(oCol, "aaa"), CollectionIndexByKey(oCol, "AAA")
    Debug.Print CollectionIndexByKey(oCol, "ddd"), CollectionIndexByKey(oCol, "aaA", IgnoreCase:=False)
    Debug.Print CollectionIndexByKey(oCol, ""), "["; CollectionKeyByIndex(oCol, 5); "]", StrPtr(CollectionKeyByIndex(oCol, 5))
    Debug.Print Join(CollectionAllKeys(oCol), ",")
    Debug.Print Join(CollectionSortedKeys(oCol), ",")
End Sub
#End If

Something is wrong. From the 64bit UDT VbCollectionItem, pPrevIndexedItem is not at offset &hH28, but at offset &H20 (16 + 8 + 8).
So o_pNextIndexedItem should be different from o_pFirstIndexedItem when executed on a 64bit Excel.
May I ask where you got the declarations of VbCollectionHeader and VbCollectionItem ?

It's possible something is wrong w/ this code as the structs are not officially documented and I just reversed them from x64 MS Office.

The important part for me is that this code works as expected both in VB6 and in x64 MS Office and it turns out o_pNextIndexedItem is equal to o_pFirstIndexedItem, though this is not that important.

Feel free to fork and fiddle with the code as much as you'd like and do post your finding back here only if you want to.

Hi wqw, do you know how the internal structure of the Collection data structure was initially discovered? It'd be nice if a similar thing was done with Excel's Range object to see if some functions could be optimised.

@sancarn I first saw Collection's internal struct posted on vbforums.com by The Trick but it seems there are various (obscure) sources on the internet and for x64 I "reversed" it easily from the 32-bit one :-))

The sample code is only retrieving info from the instance's internal state. Modifying this state would be extremely brittle so not sure how you would implement faster Union method on Range -- seems scary approach.