I've discussed all this before, but it came up again in a recent post I made (although I don't think it was considered).
Here's some code that allows using a Collection for sorting purposes (designed for a BAS module):
And here's some code for a quick test for a Form1:
As just a bit of background, keys are added into a collection using an internal binary tree. Sadly, they don't give you a way to easily traverse that binary tree, but that is rectified with the above code.
I've got no idea how this would speed compare with various quick sorts, or other sorting approaches. But I thought I'd post it here anyway. It could be particularly useful if you need to sort things stored in a Variant, based on some sort-key.
Here's some code that allows using a Collection for sorting purposes (designed for a BAS module):
Code:
Option Explicit
Option Compare Text ' This takes care of UCase$() comparisons and also the codepage.
'
' This is Public so we can use collFirstKeyAndData, etc. outside of this module.
Public Type VbCollectionKeyAndData
Key As String
Data As Variant
End Type
'
Private Type VbCollectionHeader ' Thanks go to The Trick for this.
pInterface1 As Long ' Ox00
pInterface2 As Long ' Ox04
pInterface3 As Long ' Ox08
lRefCounter As Long ' Ox0C
Count As Long ' Ox10
pvUnk1 As Long ' Ox14
pFirstIndexedItem As Long ' Ox18
pLastIndexedItem As Long ' Ox1C
pvUnk4 As Long ' Ox20
pRootTreeItem As Long ' Ox24 ' This is actually a pointer to what's typically thought of as the root.
pEndTreePtr As Long ' Ox28 ' This is effectively an EOF marker for the tree (bottom of it). It points to the end of the VbCollectionHeader (HdrPtr + &h30)
pvUnk5 As Long ' Ox2C
End Type ' Ox30 ' Length.
'
Private Type VbCollectionItem ' Thanks go to The Trick for this.
Data As Variant ' Ox00
KeyPtr As Long ' Ox10 ' This is actually a String, but it's not directly accessible. See FetchKey.
pPrevIndexedItem As Long ' Ox14
pNextIndexedItem As Long ' Ox18
pvUnknown As Long ' Ox1C
pParentItem As Long ' Ox20
pRightBranch As Long ' Ox24
pLeftBranch As Long ' Ox28
bFlag As Boolean ' Ox2C
End Type ' Ox30 ' Length. (boolean padded to 4)
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Private Declare Function GetMem4 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long
'
Private uBlankItem As VbCollectionItem
'
Public Function collFirstKey(c As Collection) As String
collFirstKey = collFirst(c).Key
End Function
Public Function collLastKey(c As Collection) As String
collLastKey = collFirst(c, True).Key
End Function
Public Function collNextKey(c As Collection) As String
collNextKey = collNext(c).Key
End Function
Public Function collPrevKey(c As Collection) As String
collPrevKey = collNext(c, True).Key
End Function
Public Function collFirstKeyAndData(c As Collection) As VbCollectionKeyAndData
collFirstKeyAndData = collFirst(c)
End Function
Public Function collLastKeyAndData(c As Collection) As VbCollectionKeyAndData
collLastKeyAndData = collFirst(c, True)
End Function
Public Function collNextKeyAndData(c As Collection) As VbCollectionKeyAndData
collNextKeyAndData = collNext(c)
End Function
Public Function collPrevKeyAndData(c As Collection) As VbCollectionKeyAndData
collPrevKeyAndData = collNext(c, True)
End Function
Public Sub collClearIterate(c As Collection)
' This does NOT remove any items.
' It is used to clear any previous iteration point.
' It is useful if we've started Adding/Deleting items. We want to be cautious.
' If we start adding/deleting items, and then call collNext/collPrev, we may crash.
' However, if this Clear is called, we'll be safe.
' Alternatively, we can just call collFirstKey/collLastKey after adding/deleting, and all will be fine.
StoreItemPtrInHeader c, 0&
End Sub
Public Function collKeyExists(c As Collection, ByVal sKey As String) As Boolean
' Dig our way to the bottom of the tree, and either find the key or not.
' This is an error-trapping free way to search.
'
Dim iItemPtr As Long
Dim iEofPtr As Long
Dim sKeyTemp As String
'
If c Is Nothing Then Exit Function ' No Collection.
'If c.Count = 0 Then Exit Function ' This isn't needed. The "If iItemPtr = iEofPtr..." serves the same purpose.
GetMem4 ByVal PtrAdd(ObjPtr(c), &H24&), iItemPtr ' VbCollectionHeader.pRootTreeItem
GetMem4 ByVal PtrAdd(ObjPtr(c), &H28&), iEofPtr ' VbCollectionHeader.pEndTreePtr
Do
If iItemPtr = iEofPtr Then Exit Do ' Hit bottom of tree. Could be true if there are no non-vbNullString keys.
GetMem4 ByVal PtrAdd(iItemPtr, &H10&), ByVal VarPtr(sKeyTemp) ' Alias the String/Key within the collection.
Select Case StrComp(sKeyTemp, sKey, vbTextCompare) ' Collection searches are NOT case sensitive (Option Compare Text).
Case -1
GetMem4 ByVal PtrAdd(iItemPtr, &H24&), iItemPtr ' VbCollectionItem.pRightBranch
Case 1
GetMem4 ByVal PtrAdd(iItemPtr, &H28&), iItemPtr ' VbCollectionItem.pLeftBranch
Case Else
collKeyExists = True ' We found our key.
Exit Do
End Select
Loop
GetMem4 0&, ByVal VarPtr(sKeyTemp) ' Clean-up our String aliasing.
End Function
' ********************************************************************
' ********************************************************************
' ********************************************************************
'
' Just private procedures for the above from here down.
'
' ********************************************************************
' ********************************************************************
' ********************************************************************
Private Function collFirst(c As Collection, Optional bGetLast As Boolean) As VbCollectionKeyAndData
' Ascii EOF (Chr$(26)) used as an EOF/BOF indicator.
' Does NOT include any items with no key.
'
If c Is Nothing Then
collFirst.Key = Chr$(26&)
collFirst.Data = collFirst.Key
Exit Function
End If
'
Dim uHdr As VbCollectionHeader
Dim uItem As VbCollectionItem
Dim iItemPtr As Long
'
' Get header and top item pointer.
CopyMemory uHdr, ByVal ObjPtr(c), LenB(uHdr)
iItemPtr = uHdr.pRootTreeItem
'
' Check if all items have vbNullString key and also the count.
If iItemPtr = EndPointer(c) Or c.Count = 0 Then
collFirst.Key = Chr$(26&)
collFirst.Data = collFirst.Key
Exit Function
End If
'
' Get top item.
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
'
' Dig to bottom of left side (or right side if we want last).
If Not bGetLast Then
Do While HasLeftBranch(c, uItem)
iItemPtr = uItem.pLeftBranch
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
Loop
Else
Do While HasRightBranch(c, uItem)
iItemPtr = uItem.pRightBranch
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
Loop
End If
'
' Return results.
StoreItemPtrInHeader c, iItemPtr ' Store item pointer in header so collNext, collPrev can work.
collFirst.Key = FetchKey(uItem) ' Return key found.
LetSetData uItem.Data, collFirst.Data ' Return data found.
'
' Mandatory cleanup. We must do this so that things in the uItem.Data don't get deallocated.
CopyMemory uItem, uBlankItem, LenB(uItem)
End Function
Private Function collNext(c As Collection, Optional bGetPrev As Boolean) As VbCollectionKeyAndData
' Ascii EOF (Chr$(26)) used as an EOF/BOF indicator.
' Does NOT include any items with no key.
'
Dim sCurrentKey As String
Dim uItem As VbCollectionItem
Dim iItemPtr As Long
'
If c Is Nothing Then
collNext.Key = Chr$(26&)
collNext.Data = collNext.Key
Exit Function
End If
'
' Fetch our current item pointer that we previously stored.
iItemPtr = GetItemPtrFromHeader(c)
If iItemPtr = 0& Then
collNext.Key = Chr$(26&)
collNext.Data = collNext.Key
Exit Function
End If
'
' Get the current item.
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
'
' Figure out which direction we're going.
Select Case True ' Comments are for collNext. collPrev is just reversed.
'
Case (HasRightBranch(c, uItem) And Not bGetPrev) Or _
(HasLeftBranch(c, uItem) And bGetPrev) ' Go right, and then as far left as we can.
If Not bGetPrev Then iItemPtr = uItem.pRightBranch _
Else iItemPtr = uItem.pLeftBranch
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
Do While (HasLeftBranch(c, uItem) And Not bGetPrev) Or _
(HasRightBranch(c, uItem) And bGetPrev)
If Not bGetPrev Then iItemPtr = uItem.pLeftBranch Else iItemPtr = uItem.pRightBranch
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
Loop
StoreItemPtrInHeader c, iItemPtr ' Save what we found for next collNext.
collNext.Key = FetchKey(uItem) ' Return key found.
LetSetData uItem.Data, collNext.Data ' Return data found.
'
Case HasUpBranch(c, uItem) ' Go up, but make sure up is greater.
sCurrentKey = FetchKey(uItem) ' We must save this before we lose it for our comparisons.
iItemPtr = uItem.pParentItem ' If it's not greater, keep going up until we find one that is.
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
Do
collNext.Key = FetchKey(uItem) ' We test and possibly return this.
If (collNext.Key >= sCurrentKey And Not bGetPrev) Or _
(collNext.Key <= sCurrentKey And bGetPrev) Then ' We use >= because they could be vbNullString if no key was specified.
StoreItemPtrInHeader c, iItemPtr ' Save what we found for next collNext.
LetSetData uItem.Data, collNext.Data ' Return data found.
Exit Do
End If
If Not HasUpBranch(c, uItem) Then ' We hit the top without finding one greater.
StoreItemPtrInHeader c, 0& ' Clear item pointer in header.
collNext.Key = Chr$(26&) ' Return EOF/BOF indicator in key.
collNext.Data = collNext.Key ' Return EOF/BOF indicator in data.
Exit Do
End If
iItemPtr = uItem.pParentItem ' We're getting the next parent to see if it's greater.
CopyMemory uItem, ByVal iItemPtr, LenB(uItem)
Loop
'
Case Else ' We hit the end. This only happens with one or two items in Collection.
StoreItemPtrInHeader c, 0& ' Clear item pointer in header.
collNext.Key = Chr$(26&) ' Return EOF/BOF indicator in key.
collNext.Data = collNext.Key ' Return EOF/BOF indicator in data.
'
End Select
'
' Mandatory cleanup. We must do this so that things in the uItem.Data don't get deallocated.
CopyMemory uItem, uBlankItem, LenB(uItem)
End Function
Private Function HasLeftBranch(c As Collection, uItem As VbCollectionItem) As Boolean
HasLeftBranch = uItem.pLeftBranch <> EndPointer(c)
End Function
Private Function HasRightBranch(c As Collection, uItem As VbCollectionItem) As Boolean
HasRightBranch = uItem.pRightBranch <> EndPointer(c)
End Function
Private Function HasUpBranch(c As Collection, uItem As VbCollectionItem) As Boolean
HasUpBranch = uItem.pParentItem <> EndPointer(c)
End Function
Private Function PtrAdd(iPtr As Long, iOffset As Long) As Long
PtrAdd = (iPtr Xor &H80000000) + iOffset Xor &H80000000
End Function
Private Sub LetSetData(DataIn As Variant, DataOut As Variant)
' This is necessary because we don't know if the item is an object or not.
' If the item is an object, just using Let will cause an error.
' We must also use DataOut passed ByRef, so we don't have to Let/Set it again from a Function.
If IsObject(DataIn) Then Set DataOut = DataIn Else DataOut = DataIn
End Sub
Private Sub LetStringArray(sa() As String, idx As Long, sVal As String)
' Necessary because, if the array is the function name, you can't assign from within the function.
sa(idx) = sVal
End Sub
Private Function EndPointer(c As Collection) As Long
' This is effectively an EOF (or end-of-branch) marker that's used by VB6's Collections.
' They DON'T use zero for this, and each Collection will have a different value.
' It's basically a pointer back to the bottom of the Collection header.
GetMem4 ByVal PtrAdd(ObjPtr(c), &H28&), EndPointer ' VbCollectionHeader.pEndTreePtr
End Function
Private Function StoreItemPtrInHeader(c As Collection, iItemPtr As Long)
Dim uHdr As VbCollectionHeader
CopyMemory uHdr, ByVal ObjPtr(c), LenB(uHdr)
uHdr.pvUnk4 = iItemPtr
CopyMemory ByVal ObjPtr(c), uHdr, LenB(uHdr)
End Function
Private Function GetItemPtrFromHeader(c As Collection) As Long
Dim uHdr As VbCollectionHeader
CopyMemory uHdr, ByVal ObjPtr(c), LenB(uHdr)
GetItemPtrFromHeader = uHdr.pvUnk4
End Function
Private Function FetchKey(uItem As VbCollectionItem) As String
Dim sKeyTemp As String
GetMem4 uItem.KeyPtr, ByVal VarPtr(sKeyTemp) ' Key string of collection item.
FetchKey = sKeyTemp ' Copy key into FetchKey string.
GetMem4 0&, ByVal VarPtr(sKeyTemp) ' Make string empty again to keep memory straight.
End FunctionCode:
Option Explicit
'
Private Sub Form_Load()
Dim c As New Collection
Dim sKey As String
c.Add "qwer", "qqq"
c.Add "asdf", "aaa"
c.Add "zxcv", "zzz"
If c.Count Then
Debug.Print collFirstKey(c)
Do
sKey = collNextKey(c)
If sKey = Chr$(26) Then Exit Do
Debug.Print sKey
Loop
End If
End SubI've got no idea how this would speed compare with various quick sorts, or other sorting approaches. But I thought I'd post it here anyway. It could be particularly useful if you need to sort things stored in a Variant, based on some sort-key.