[VB6/VBA] Collection keys

These are x64 and 32-bit implementations of some keys access/enumeration functions for built-in VBA.Collection class as discussed in http://www.vbforums.com/showthread.p...ted-Collection

The internal VbCollectionHeader and VbCollectionItem structs are declared w/ member offsets both for x64 and 32-bit implementations and the raw pointer access is implemented in bitness agnostic fashion w/ PTR_SIZE const and VbCollectionOffsets enum members e.g. single code Call CopyMemory(lPtr, ByVal lPtr + o_pNextIndexedItem, PTR_SIZE) works correctly both for x64 and 32-bit versions the same.

The mystery coincidence of matching offset for VbCollectionHeader.pNextIndexedItem and VbCollectionItem.pFirstIndexedItem holds true for x64 versions of the internal structs, so IMO this is very deliberate impl. detail.

thinBasic Code:

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

cheers,
</wqw>

There is a more elegant way of getting a string from a pointer. Also, dereferencing that pointer probably isn't really necessary because the KeyPtr member of the VbCollectionItem structure is apparently a BSTR.

Can you tell me exactly which one derefencing method do you mean? Mind that keys are BSTRs and can contain '\0' chars so it has to be SysAllocStringByteLen based.

I'm not using the structs in the code. They are included only to document the offsets for x64 and i386 and can be safely removed. The snippet is using offsets from VbCollectionOffsets for direct pointer arithmetic.

The interesting part for VB6 coders is VBA's new PtrSafe declare's for both x64 and 32-bit declares, LongPtr for 4 vs 8-byte wide pointers, Win64 conditional compilation and the derivative PTR_SIZE and NULL_PTR to handle pointers invariantly to bitness.

Also here is the ArrPtr 64-bit declare:

Code:

---

Private Declare PtrSafe Function ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) As LongPtr

---

Edit: Notice also that sizeof VARIANT struct has increased from 16 to 24 bytes.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

Can you tell me exactly which one derefencing method do you mean? Mind that keys are BSTRs and can contain '\0' chars so it has to be SysAllocStringByteLen based.

---

You're right. SysAllocString/SysReAllocString will fail if the string contains embedded vbNullChar(s). In that case, SysReAllocStringLen+SysStringLen should be used.

Cool stuff Wqweto. :)

I tend to try and keep all my code in VB6, but there is one specific Excel file I use that'll always have a substantial amount of VBA code on it. At present, I don't make any use of the Collection class in it, but I could see myself doing that in the future. Also, I could see myself willy-nilly pulling some of the Collection sort procedures into it, not thinking about the 64-bit situation. In fact, I hadn't even thought about Variants being 24 bytes in a 64-bit environment.

All this just makes me pine for a stand-alone COM based VB7 though.

Take Care,
Elroy

Just added CollectionIndexByKey function that can be used for *case-sensitive* key existence check too.

cheers,
</wqw>

Not to complicate things, but patched versions of 32bit office are LAA.

Are these common? I think x64 offices are more common than 32-bit versions nowadays and so the incentive to deal w/ all the trouble of being flagged LARGEADDRESSAWARE is diminishing IMO.

For now I prefer to leave reducing LargeAddressAware const to #Const LargeAddressAware = (Win64 = 0) an open question and at the discretions of this module's end-users.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

I think x64 offices are more common than 32-bit versions nowadays

---

Hey Wqweto, that's certainly not the world I live in. Many of the Windows OS's are 64-bit, but Office is lagging behind that quite badly. I'm always working in hospital environments (specifically, motion analysis laboratories), and they seem to always have site licenses for Office. I've got no idea how that works, and I've never asked. But they just keep installing 32-bit Office on all their new machines.

In fact, so far, the only time I've run into Office 64-bit is on the personal laptops of various researchers who work with the hospitals. I'm not sure I've even seen a version of Office 64-bit on any of the computers I see in the hospitals.

Just Sharing,
Elroy

originally the best practice was to install 32bit office in enterprise environments mostly due to compatibility with all the existing plugins and ODBC drivers. Someday that may change - when all those legacy adapters get updated for 64bit? We've got Office 365 at 32bit here.

Unfortunately MS again missed to implement LongPtr w/ unsigned semantics or at least they could have just made the compiler remain silent on &7FFFFFFF overflow.

Such a great opportunity to impl true 4GB address arithmetics on the new type and they just aliased it to Long probably impl w/ the least efforts possible but didn't think twice before breaking backwards comp w/ PtrSafe declares -- all the client code has to be refactored w/ conditional compilation is not their problem.

cheers,
</wqw>
p.s. I just checked LongPtr arith on 32-bit Excel Build 15.0.4833.1000 that is supposed to be *the* LAA version.

Why are you able to understand the internal structure of these Collection types? Did you decompile him?