[VB6/VBA] Collection keys
February 22, 2019 ยท View on GitHub
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