How much do you trust the Collection class?

@pekko, that's certainly an interesting piece of code. There's not a great deal that makes me nervous, but altering the memory-loaded machine code (actually, data, I suppose), of what is essentially now an OS file, does. We'd have to thoroughly test anytime the checksum of the MSVBVM60.DLL file changed.

I suppose I'm doing something similar when I fetch the string keys from memory. However, at least that's based on my own executable, and not a file provided by the OS (and I'm only reading memory). I also wonder how the change affects other things, like how StrComp works, and whether or not Option Compare will still have the same effect.

Again, it's certainly interesting though. It's too bad they didn't just expose such a property on Collections (possibly disabling writing to it once items are added). I cringe to bring it up, but I also wonder what effect it'll have on the operation of any "under the hood" hash-table. Clearly, we'd have a mess if we made this PatchCollection(IsCaseSensitive = True) call, added keys like "asdf", "ASDF", etcetera, and then called PatchCollection(IsCaseSensitive = False).

Regards,
Elroy

What i've found out.
VB6 collection is binary tree. An collection object contains all the items in the double linked list and all the items with keys in the tree. When you try to access to an item with key it searches one in the tree and if you access to item by the index it enumerates all the item until the specified item found. I've created an analog of Add method and Item property using reverse-engineering of code of MSVBVM60 runtime on Windows 7 x64. Because of VB6 doesn't supports pointers to UDT i've implemented it through classes.
All the offsets correspond to the native Collection structure (for example, if you change classes to udt, change work with the references and use the native VB memory allocator you can pass an collection object to Add/Item functions - it'll work correctly. If somebody will wonder i can implement Remove method too (i glance at Remove method and it uses some unknown structures (pvUnk4 for example)).
Class CVBCollection:

Code:

---

' //
' // Native VB collection
' // Decompiled by The trick
' //

Option Explicit

Private Const DISP_E_PARAMNOTFOUND        As Long = &H80020004
Private Const CTL_E_ILLEGALFUNCTIONCALL  As Long = &H800A0005
Private Const DISP_E_OVERFLOW            As Long = &H8002000A
Private Const E_OUTOFMEMORY              As Long = &H8007000E

Public pInterface1        As IUnknown            ' // 0x00
Public pInterface2        As IUnknown            ' // 0x04
Public pInterface3        As IUnknown            ' // 0x08
Public lRefCounter        As Long                ' // 0x0C
Public lNumOfItems        As Long                ' // 0x10
Public pvUnk1              As Long                ' // 0x14
Public pFirstIndexedItem  As CVBCollectionItem  ' // 0x18
Public pLastIndexedItem    As CVBCollectionItem  ' // 0x1C
Public pvUnk4              As Long                ' // 0x20
Public pFirstItem          As CVBCollectionItem  ' // 0x24
Public pRootItem          As CVBCollectionItem  ' // 0x28
Public pvUnk5              As Long                ' // 0x2C

' // Get item
Public Property Get Item( _
                    ByRef vKeyIndex As Variant) As Variant
    Dim hr      As Long
    Dim pItem  As CVBCollectionItem
   
    hr = GetItemByKey(vKeyIndex, pItem)
   
    If hr < 0 Then
        Err.Raise hr
        Exit Property
    End If
   
    If IsObject(pItem.vtItem) Then
        Set Item = pItem.vtItem
    Else
        Item = pItem.vtItem
    End If
   
End Property

' // Add item to collection
Public Sub Add( _
          ByRef vItem As Variant, _
          Optional ByRef vKey As Variant, _
          Optional ByRef vBefore As Variant, _
          Optional ByRef vAfter As Variant)
    Dim bIsEmptyKey    As Boolean
    Dim bIsEmptyBefore  As Boolean
    Dim bIsEmptyAfter  As Boolean
    Dim vIndex          As Variant
    Dim pNewItem        As CVBCollectionItem
    Dim pItem          As CVBCollectionItem
    Dim pTempItem      As CVBCollectionItem
    Dim bstrKey        As String
    Dim hr              As Long
   
    bIsEmptyKey = IsMissingParam(vKey)
    bIsEmptyBefore = IsMissingParam(vBefore)
    bIsEmptyAfter = IsMissingParam(vAfter)
   
    If bIsEmptyBefore Then
        If Not bIsEmptyAfter Then
            vIndex = vAfter
        End If
    Else
        If Not bIsEmptyAfter Then
            Err.Raise CTL_E_ILLEGALFUNCTIONCALL
            Exit Sub
        End If
        vIndex = vBefore
    End If
   
    If lNumOfItems < 0 Then
        Err.Raise DISP_E_OVERFLOW
        Exit Sub
    End If
   
    If bIsEmptyKey Then
        Set pNewItem = New CVBCollectionItem
    Else
       
        hr = GetItemByKey(vKey, pNewItem)
        If hr >= 0 Then
            Err.Raise &H800A01C9
            Exit Sub
        End If
       
        ' // 48
        Set pNewItem = New CVBCollectionItem
       
        bstrKey = BSTRKeyFromVariant(vKey)
       
        If Len(bstrKey) = 0 Then
            Err.Raise &H800A000D
            Exit Sub
        End If
       
        pNewItem.bstrKey = bstrKey
        pNewItem.bFlag = False
       
        Set pNewItem.pRight = pRootItem
        Set pNewItem.pLeft = pRootItem
       
    End If
   
    ' // VariantCopyInd
    pNewItem.vtItem = vItem
 
    If IsEmpty(vIndex) Then
        Set pItem = pLastIndexedItem
    Else
   
        hr = GetItemByKey(vIndex, pItem)
        If hr < 0 Then
            Err.Raise hr
            Exit Sub
        End If
       
        If Not bIsEmptyBefore Then
            Set pItem = pItem.pPrevIndexedItem
        End If
       
    End If
   
    If Not bIsEmptyBefore And pItem Is Nothing Then
   
        Dim pTmpItem As CVBCollectionItem
       
        Set pTmpItem = pFirstIndexedItem
        Set pFirstIndexedItem = pNewItem
        Set pTmpItem.pPrevIndexedItem = pNewItem
        Set pNewItem.pPrevIndexedItem = Nothing
        Set pNewItem.pNextIndexedItem = pTmpItem
       
    Else
   
        If Not pItem Is Nothing Then
       
            Set pNewItem.pNextIndexedItem = pItem.pNextIndexedItem
           
            If Not pItem.pNextIndexedItem Is Nothing Then
                Set pNewItem.pNextIndexedItem.pPrevIndexedItem = pNewItem
            Else
                Set pLastIndexedItem = pNewItem
            End If
           
            Set pItem.pNextIndexedItem = pNewItem
           
        Else
       
            Set pNewItem.pNextIndexedItem = Nothing
            Set pFirstIndexedItem = pNewItem
            Set pLastIndexedItem = pNewItem
         
        End If
       
    End If
   
    Set pNewItem.pPrevIndexedItem = pItem

    If Not bIsEmptyKey Then
        AddItemWithKeyToTree pNewItem
    End If
   
    lNumOfItems = lNumOfItems + 1
   
End Sub

' // Get item by variant key/index
Private Function GetItemByKey( _
                ByRef vKey As Variant, _
                ByRef pOutItem As CVBCollectionItem) As Long
    Dim bIsEmptyKey As Boolean
    Dim bstrKey    As String
    Dim lIndex      As Long
    Dim pItem      As CVBCollectionItem
   
    bIsEmptyKey = IsMissingParam(vKey)

    If bIsEmptyKey Or pFirstIndexedItem Is Nothing Then
        GetItemByKey = CTL_E_ILLEGALFUNCTIONCALL
        Exit Function
    End If
   
    bstrKey = BSTRKeyFromVariant(vKey)
   
    ' // This is string key
    If Len(bstrKey) Then
       
        Set pOutItem = FindItemFrom(pFirstItem, bstrKey)
       
        If pOutItem Is pRootItem Then
            GetItemByKey = CTL_E_ILLEGALFUNCTIONCALL
            Exit Function
        End If
       
    Else
   
        lIndex = Int(vKey)
       
        If lIndex <= 0 Or lIndex > lNumOfItems Then
            GetItemByKey = &H800A000D
            Exit Function
        End If

        Set pOutItem = pFirstIndexedItem

        Do Until lIndex = 1
            Set pOutItem = pOutItem.pNextIndexedItem
            lIndex = lIndex - 1
        Loop
       
    End If
   
End Function

' // Add item that has a key to tree
Private Function AddItemWithKeyToTree( _
                ByVal pItem As CVBCollectionItem) As Long
    Dim pCurItem            As CVBCollectionItem
    Dim pParentItem        As CVBCollectionItem
    Dim pParentParentItem  As CVBCollectionItem
    Dim pParentLeft        As CVBCollectionItem

    ' // Insert item to tree
    InsertItemToTree pItem
   
    pItem.bFlag = False
   
    Set pCurItem = pItem
   
    Do Until pCurItem Is pFirstItem
   
        Set pParentItem = pCurItem.pParentItem
       
        If pParentItem.bFlag Then Exit Do
       
        Set pParentParentItem = pParentItem.pParentItem
        Set pParentLeft = pParentParentItem.pLeft
       
        If pParentItem Is pParentLeft Then
           
            Set pParentLeft = pParentParentItem.pRight
           
            If Not pParentLeft.bFlag Then
           
                pParentItem.bFlag = True
                pParentLeft.bFlag = True
                pParentItem.pParentItem.bFlag = False
                Set pCurItem = pCurItem.pParentItem.pParentItem
               
            Else
           
                If pCurItem Is pParentItem.pParentItem Then
               
                    Set pCurItem = pCurItem.pParentItem
                    MoveDownRight pParentItem
                   
                Else
               
                    pParentItem.bFlag = True
                    pParentItem.pParentItem.bFlag = False
                    MoveDownLeft pCurItem.pParentItem.pParentItem
               
                End If
               
            End If
           
        Else
           
            If pParentLeft.bFlag Then
           
                If pCurItem Is pParentItem.pLeft Then
               
                    Set pCurItem = pCurItem.pParentItem
                    MoveDownLeft pParentItem
               
                Else
                   
                    pParentItem.bFlag = True
                    pParentItem.pParentItem.bFlag = False
                    MoveDownRight pCurItem.pParentItem.pParentItem
                   
                End If
               
            Else
           
                pParentItem.bFlag = True
                pParentLeft.bFlag = True
                pParentItem.pParentItem.bFlag = False
                Set pCurItem = pCurItem.pParentItem.pParentItem
               
            End If

        End If
   
    Loop
   
    pFirstItem.bFlag = True
   
End Function

' // Move tree item down and left
Private Sub MoveDownLeft( _
            ByVal pItem As CVBCollectionItem)
    Dim pParentLeft  As CVBCollectionItem
   
    Set pParentLeft = pItem.pLeft
    Set pItem.pLeft = pParentLeft.pRight
   
    If Not pParentLeft.pRight Is pRootItem Then
        Set pParentLeft.pRight.pParentItem = pItem
    End If
   
    Set pParentLeft.pParentItem = pItem.pParentItem
   
    If pItem.pParentItem Is pRootItem Then
        Set pFirstItem = pParentLeft
    Else
        If pItem Is pItem.pParentItem.pRight Then
            Set pItem.pParentItem.pRight = pParentLeft
        Else
            Set pItem.pParentItem.pLeft = pParentLeft
        End If
    End If
   
    Set pParentLeft.pRight = pItem
    Set pItem.pParentItem = pParentLeft
   
End Sub

' // Move tree item down and right
Private Sub MoveDownRight( _
            ByVal pItem As CVBCollectionItem)
    Dim pRight  As CVBCollectionItem
   
    Set pRight = pItem.pRight
    Set pItem.pRight = pRight.pLeft
   
    If Not pRight.pLeft Is pRootItem Then
        Set pRight.pLeft.pParentItem = pItem
    End If
   
    Set pRight.pParentItem = pItem.pParentItem
   
    If pItem.pParentItem Is pRootItem Then
        Set pFirstItem = pRight
    Else
        If pItem Is pItem.pParentItem.pLeft Then
            Set pItem.pParentItem.pLeft = pRight
        Else
            Set pItem.pParentItem.pRight = pRight
        End If
    End If
   
    Set pRight.pLeft = pItem
    Set pItem.pParentItem = pRight
   
End Sub

' // Insert item to tree
Private Function InsertItemToTree( _
                ByVal pItem As CVBCollectionItem) As Long
    Dim pCurItem    As CVBCollectionItem
    Dim pParentItem As CVBCollectionItem
    Dim hr          As Long
   
    Set pParentItem = pRootItem
    Set pCurItem = pFirstItem
   
    ' // Check if item exists
    If Not pParentItem Is pCurItem Then
       
        ' // Find tree node for passed item
        Do
       
            Set pParentItem = pCurItem
           
            hr = StrComp(pItem.bstrKey, pCurItem.bstrKey, vbTextCompare) + 1
           
            Select Case hr
            Case 0
                Set pCurItem = pCurItem.pLeft
            Case 1
                ' // Error. Specified item already exists
                InsertItemToTree = &H800A01C9
                Exit Function
            Case 2
                Set pCurItem = pCurItem.pRight
            End Select
           
        Loop Until pCurItem Is pRootItem
       
    Else:  hr = ObjPtr(pItem)
    End If
   
    ' // Set parent node for passed item
    Set pItem.pParentItem = pParentItem
   
    ' // Check if it is the root node
    If pParentItem Is pRootItem Then
        Set pFirstItem = pItem
    Else
        ' // Place item depending on value
        If hr Then
            Set pParentItem.pRight = pItem
        Else
            Set pParentItem.pLeft = pItem
        End If
    End If
   
End Function
               
' // Find an item by key from specified item
Private Function FindItemFrom( _
                ByVal pStartItem As CVBCollectionItem, _
                ByRef bstrKey As String) As CVBCollectionItem
    Dim pCurItem    As CVBCollectionItem
   
    Set pCurItem = pStartItem
   
    Do Until pCurItem Is pRootItem
   
        Select Case StrComp(bstrKey, pCurItem.bstrKey, vbTextCompare)
        Case -1:    Set pCurItem = pCurItem.pLeft
        Case 0:    Exit Do
        Case 1:    Set pCurItem = pCurItem.pRight
        End Select
       
    Loop
   
    Set FindItemFrom = pCurItem
   
End Function

' // Convert a variant value to string
Private Function BSTRKeyFromVariant( _
                ByRef vKey As Variant) As String
    Dim vTemp  As Variant
    Dim pTmpObj As Object
   
    If IsObject(vKey) Then
   
        Set pTmpObj = vKey
       
        If Not pTmpObj Is Nothing Then
            vTemp = CStr(vKey)
        Else
            Set vTemp = vKey
        End If
   
    Else
        vTemp = vKey
    End If
   
    If VarType(vTemp) = vbString Then
        BSTRKeyFromVariant = CStr(vTemp)
    End If
   
End Function

Private Function IsMissingParam( _
                ByRef vParam As Variant) As Boolean
               
#If COMPILED Then
   
    If IsError(vParam) Then
        If CInt(vParam) = DISP_E_PARAMNOTFOUND Then
            IsMissingParam = True
        End If
    End If
   
#Else

    IsMissingParam = IsMissing(vParam)
   
#End If

End Function

Private Sub Class_Initialize()

    Set pRootItem = New CVBCollectionItem
    Set pFirstItem = pRootItem
   
#If Not COMPILED Then
   
    pRootItem.bstrKey = "root"
   
#End If

End Sub

---

Class CVBCollectionItem:

Code:

---

' //
' // Native VB collection item
' // Decompiled by The trick
' //

Option Explicit

Public vtItem              As Variant
Public bstrKey            As String
Public pPrevIndexedItem    As CVBCollectionItem
Public pNextIndexedItem    As CVBCollectionItem
Public pvUnknown          As Long
Public pParentItem        As CVBCollectionItem
Public pRight              As CVBCollectionItem
Public pLeft              As CVBCollectionItem
Public bFlag              As Boolean

---

When you skip Key, Before, After in Add method of the native collection it passes VT_ERROR with DISP_E_PARAMNOTFOUND value indeed.

Makes sense. Hashes and trees are the two most common ways of implementing an indexed data structure, so it almost had to be one or the other.

A lot of the Collection alternatives you see out there tend to use one type of tree or another. I suppose you could even use both: a relatively fast but short hash (8 to 12 bits?) to select among multiple shallower trees.

Related topic with collection structure,
and (if you are interested) with Dictionary structure.

Quote:

---

Originally Posted by DEXWERX

It would be nice to know what APIs are being used, where the HashMap is, and What HashFunction is used.

---

This function is used for key comparison:

Code:

---

VarBstrCmp(bstr1, bstr2, 1, &H30001)

---

Trick, you are amazing, as always. Thank you for sharing your findings.

Thanks also to dseaman earlier in the thread for conclusively demonstrating that the problems seem to occur with malformed surrogate pair markers.

I'm still confused why the error only appears intermittently. You'd think it would occur every time that VarBstrCmp() call attempts to match a malformed key string. I'm also confused by the specific compare flags used - &H1 is "ignore case", which makes sense, but what on earth is &h30000? An undocumented internal flag?

Yes, I've got to give a shout-out to Trick as well. That's amazing stuff. VB6 collections finally completely revealed.

Regards,
Elroy

Quote:

---

Originally Posted by Tanner_H

but what on earth is &h30000? An undocumented internal flag?

---

Generally VarBstrCmp calls CompareString function and passes dwFlags as dwCmpFlags. If you see to description 0x00030000 means NORM_IGNOREWIDTH|NORM_IGNOREKANATYPE. I guess it's just an error in the documentation of VarBstrCmp function.

Say Trick, I was just playing around (and looking at the code of) your Dictionary Viewer. That's super cool stuff.

Now that we have a way to retrieve the keys of dictionary items, we should all probably switch over to the Dictionary, rather than using Collections.

From other threads, it seems to be much faster.

I guess the only thing we lose is the ability to have an index-order in addition to the keys, but that doesn't seem like much of a loss to me.

I haven't used the Microsoft Scripting Runtime that much (scrrun.dll). Can we depend on that being available on all contemporary versions of Windows? (Anyone is welcome to answer this.)

Again, Trick, SUPER-cool stuff. :)

Elroy

Yes, the Scripting Runtime library ships in Windows and has for ages.

These classes do different things and which to choose depends on the task.

There are some things about the Dictionary that can be inefficient such as its flawed iteration model. That retrieves a copy of Items() as a temporary array that you iterate over. Heavy use of small Dictionaries (e.g. in object hierarchies) seems to use more memory too. So you have a ton more memory allocation and deallocation going on unless you are doing trivial things.

Collection wrapper classes with efficient iteration are fairly trivial to implement. Code similar to that of the VB.Collection is widely used by Microsoft ActiveX controls anyway. Code similar to that is used in MSHTML and MSXML DOMs. If there was a batter way that made sense they probably would have used it.

There are other things about Dictionary that run in its favor. For example easy access to the Keys() array can make Dictionary easier to persist when necessary.

Both have plusses and minuses, so pick the one that fits. Sometimes neither one fits, so you either get tricky and force it or create some ad hoc alternative data structure.

@Elroy, my clsTrickHashTable has the same features as Dictionary plus additional. You can use it just add the single class.
BTW, there is the many tree-algorithms as well. For example, when i was doing my COFF parser i needed the fast access to item using pointer. This is example:

Code:

---

' //
' // Simple tree by The trick (access to item by Long index)
' //

Option Explicit

' // Tree node. It is used to associate objects and indices
Private Type TreeNode
    ChildNodesIndices()        As Long        ' // Indices of the children nodes
    IsInitialized              As Boolean      ' // Determine if ChildNodes array is initialized
    ItemIndex                  As Long        ' // Item index from 1
End Type

' // Tree item
Private Type TreeItem
    lItemValue                  As Long
    sItemString                As String
    ' // You can add any other values
End Type

' // Tree object
Private Type Tree
    NumberOfNodes              As Long
    NumberOfItems              As Long
    Children()                  As TreeNode
    Items()                    As TreeItem
End Type

Private Sub Form_Load()
    Dim pTree  As Tree
    Dim index  As Long
   
    InitTree pTree
   
    For index = 0 To 10000
       
        Select Case index
        Case 0:    AddItemToTree pTree, 0, CreateTreeItem(1245232, "Item5")
        Case 1345:  AddItemToTree pTree, 12345434, CreateTreeItem(123, "Item1")
        Case 112:  AddItemToTree pTree, 346235, CreateTreeItem(5, "Item2")
        Case 12:    AddItemToTree pTree, 1212342, CreateTreeItem(8, "Item3")
        Case 5674:  AddItemToTree pTree, 56456, CreateTreeItem(2349, "Item4")
        Case Else
            AddItemToTree pTree, Int(Rnd * 1241254121), CreateTreeItem(Int(Rnd * 12312), "Item" & index)
        End Select
       
    Next

    PrintItem TreeItemByKey(pTree, 56456)
    PrintItem TreeItemByKey(pTree, 1212342)
    PrintItem TreeItemByKey(pTree, 346235)
    PrintItem TreeItemByKey(pTree, 12345434)
    PrintItem TreeItemByKey(pTree, 0)
   
End Sub

' // Print item
Private Function PrintItem( _
                ByRef pItem As TreeItem) As Boolean
    Debug.Print pItem.lItemValue, pItem.sItemString
End Function

' // Create item
Private Function CreateTreeItem( _
                ByVal lValue As Long, _
                ByRef sString As String) As TreeItem
    CreateTreeItem.lItemValue = lValue
    CreateTreeItem.sItemString = sString
End Function

' // Initialize tree
Private Sub InitTree( _
            ByRef treObject As Tree)
               
    treObject.NumberOfItems = 0
    treObject.NumberOfNodes = 1
   
    ReDim treObject.Children(0)
    ReDim treObject.Items(100)
   
End Sub

' // Get element by key
Private Function TreeItemByKey( _
            ByRef treObject As Tree, _
            ByVal lngKeyValue As Long) As TreeItem
    Dim pathIndex  As Long
    Dim pathItem    As Long
    Dim curItem    As Long
    Dim nextItem    As Long
    Dim nullPath    As Boolean
   
    nullPath = True
    curItem = 0
   
    With treObject
       
        For pathIndex = 0 To 7
           
            ' // Get path element
            pathItem = ((lngKeyValue And &HF0000000) \ &H10000000) And &HF
           
            ' // Remove previous zeros
            If nullPath And pathItem Then
                nullPath = False
            End If
           
            If Not nullPath Then

                ' // Check if array of child nodes is initialized
                If Not .Children(curItem).IsInitialized Then
                   
                    Err.Raise 389
                    Exit Function
                   
                End If

                nextItem = .Children(curItem).ChildNodesIndices(pathItem) - 1
               
                ' // Node is not allocated
                If nextItem = -1 Then

                    Err.Raise 389
                    Exit Function
                   
                Else
                   
                    nextItem = nextItem + 1
                   
                End If
               
                curItem = nextItem
               
            End If
           
            ' // Next path element
            lngKeyValue = lngKeyValue And &HFFFFFFF
           
            If lngKeyValue And &H8000000 Then
                lngKeyValue = (lngKeyValue And &H7FFFFFF) * &H10 Or &H80000000
            Else
                lngKeyValue = lngKeyValue * &H10
            End If

        Next
       
        ' // Check if element exist
        If .Children(curItem).ItemIndex = 0 Then
           
            Err.Raise 389
            Exit Function
           
        End If
       
        TreeItemByKey = .Items(.Children(curItem).ItemIndex - 1)
       
    End With
 
End Function

' // Add value to tree
Private Sub AddItemToTree( _
            ByRef treObject As Tree, _
            ByVal lngKeyValue As Long, _
            ByRef pValue As TreeItem)
    Dim pathIndex  As Long
    Dim pathItem    As Long
    Dim curItem    As Long
    Dim nextItem    As Long
    Dim nullPath    As Boolean
   
    nullPath = True
    curItem = 0
   
    With treObject
       
        For pathIndex = 0 To 7
           
            ' // Get path element
            pathItem = ((lngKeyValue And &HF0000000) \ &H10000000) And &HF
           
            ' // Remove previous zeros
            If nullPath And pathItem Then
                nullPath = False
            End If
           
            If Not nullPath Then

                ' // Check if array of child nodes is initialized
                If Not .Children(curItem).IsInitialized Then
                   
                    ReDim .Children(curItem).ChildNodesIndices(&HF)
                    .Children(curItem).IsInitialized = True
                   
                End If

                nextItem = .Children(curItem).ChildNodesIndices(pathItem) - 1
               
                ' // Node is not allocated
                If nextItem = -1 Then
                   
                    If .NumberOfNodes > UBound(.Children) Then
                   
                        ReDim Preserve .Children(.NumberOfNodes + 100)
                       
                    End If
                   
                    .Children(curItem).ChildNodesIndices(pathItem) = .NumberOfNodes
                    nextItem = .NumberOfNodes
                    .NumberOfNodes = .NumberOfNodes + 1
               
                Else
                   
                    nextItem = nextItem + 1
                   
                End If
               
                curItem = nextItem
               
            End If
           
            ' // Next path element
            lngKeyValue = lngKeyValue And &HFFFFFFF
           
            If lngKeyValue And &H8000000 Then
                lngKeyValue = (lngKeyValue And &H7FFFFFF) * &H10 Or &H80000000
            Else
                lngKeyValue = lngKeyValue * &H10
            End If

        Next
       
        ' // Check if element exist
        If .Children(curItem).ItemIndex Then
           
            Err.Raise 457
            Exit Sub
           
        End If
       
        If .NumberOfItems > UBound(.Items) Then
       
            ReDim Preserve .Items(.NumberOfItems + 100)
           
        End If
       
        .Items(.NumberOfItems) = pValue
        .NumberOfItems = .NumberOfItems + 1
       
        .Children(curItem).ItemIndex = .NumberOfItems
       
    End With
   
End Sub

---

This code creates the path using nibbles of the key value as path components. You can change it to access to item by string key as well.

Cool stuff, Trick. Thank you!

I grabbed the clsTrickHashTable and the little demo from the link, and will take a look at it.

It's truly amazing to see some of the stuff you've dug out of VB6. I think you're the guy who should write a 100% compatible VB6 Open Source compiler. :p

Then, all we'd need is for someone to write an Open Source p-code interpreter (with break-points) and we'd be in business. Heck, I could learn to use Eclipse or Notepad++ to write my source code.

Well anyway, all just pipe-dreams I suspect.

You take care,
Elroy

I guess I couldn't help myself. Based heavily on the information The Trick gave us, here's how to search a VBA.Collection sort-of-the-hard way. Logically, it does it the same way the Collection itself does it. However, it's moving memory around quite a bit more, just because that's required by VB6 to not corrupt memory.

So.... here's the code:

Code:

---


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
'

Private Type VbCollectionHeader
    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
    Data              As Variant  '  Ox00
    Key                As String  '  Ox10
    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 Sub Form_Load()
    Dim c As New Collection
    Dim uHead As VbCollectionHeader
    Dim uItem As VbCollectionItem
    Dim ptr As Long
    Dim b As Boolean
    Dim vData As Variant
    Dim i As Long
    Dim s As String
    Dim sKeyToSearchFor As String


    For i = 1 To 8
        s = Right$("000" & CStr(Int(Rnd * 1000)), 4)
        c.Add s & "Data", s & "Key"
        '
        If i = 6 Then sKeyToSearchFor = s & "Key"
    Next i


    ' First, let's just list the items in the debug window.
    ptr = uHead.pFirstIndexedItem
    Do While ptr
        uItem = GetCollectionItem(ptr)
        Debug.Print uItem.Key, uItem.Data, "My ptr: "; Hex$(ptr)  ', "Next ptr: "; uItem.pNextIndexedItem
        ptr = uItem.pNextIndexedItem
    Loop


    ' Now, we're going to search for a key in the collection, but doing it ourselves with the B-Tree.
    MsgBox "We're going to look for: " & sKeyToSearchFor
    b = GetItemByKey(c, sKeyToSearchFor, vData)
    If b Then
        MsgBox "Data is: " & vData
    Else
        MsgBox "not found"
    End If


    Unload Me
End Sub

Private Function GetCollectionHeader(c As Collection) As VbCollectionHeader
    CopyMemory GetCollectionHeader, ByVal ObjPtr(c), LenB(GetCollectionHeader)
End Function

Private Function GetCollectionItem(ptr As Long) As VbCollectionItem
    ' This will work for either Next or Prev, because it just uses pointer.
    ' It will also work with the BTree pointers.
    ' Be careful.  This does NOT check the validity of the pointer.
    ' Index pointer will be ZERO when end has been reached.
    ' Tree pointers will be VbCollectionHeader.pEndTreePtr when end has been reached.
    '
    ' This is a bit tricky because we don't want to alias the Data or Key variables from the actual Collection data.
    ' VB6 doesn't particularly like aliasing non-object variable types, particularly when one of the aliases may go out of scope.
    '
    Dim s As String
    Dim t(0 To 4) As Long ' 20 bytes.
    Dim i As Long
    Dim v As Variant
    '
    CopyMemory t(0), ByVal VarPtr(GetCollectionItem.Data), &H14                    ' Save original variant and string pointer stuff.
    CopyMemory ByVal VarPtr(GetCollectionItem), ByVal ptr, LenB(GetCollectionItem)  ' Copy the structure.
    CopyMemory GetCollectionItem.Data, t(0), &H14                                  ' Put back original variant and string pointer.  We must handle this differently.
    '
    ' Now, get the key, borrowing another string for a moment.
    i = StrPtr(s)                                          ' Save string pointer because we're going to borrow the string.
    CopyMemory ByVal VarPtr(s), ByVal ptr + &H10, &H4      ' Key string of collection item.
    GetCollectionItem.Key = s                              ' Move key into structure.
    CopyMemory ByVal VarPtr(s), i, &H4                      ' Put string pointer back to keep memory straight.
    '
    ' Now, get the data, borrowing another variant for a moment.
    CopyMemory t(0), ByVal VarPtr(v), &H10                  ' Save variant data (16 bytes, including any pointers).  We're going to borrow it.
    CopyMemory ByVal VarPtr(v), ByVal ptr, &H10            ' Copy item's variant into our temp variant.
    If IsObject(v) Then
        Set GetCollectionItem.Data = v                      ' Put temp variant into structure.
    Else
        GetCollectionItem.Data = v                          ' Put temp variant into structure.
    End If
    CopyMemory ByVal VarPtr(v), t(0), &H10                  ' Put original variant data back to keep memory straight.
End Function

Private Function GetItemByKey(c As Collection, Key As String, vData As Variant) As Boolean
    ' Returns TRUE if found.
    ' Returns FALSE if not found.
    ' Returns FALSE if Len(Key) = 0.
    Dim pItem As Long
    Dim Header As VbCollectionHeader
    Dim Item As VbCollectionItem
    '
    If Len(Key) = 0 Then Exit Function
    '
    Header = GetCollectionHeader(c)
    pItem = Header.pRootTreeItem
    '
    Do Until pItem = Header.pEndTreePtr
        Item = GetCollectionItem(pItem)
        Select Case StrComp(Item.Key, Key, vbTextCompare) ' <---- Donar's identified issue in post #1.
        Case 1:    pItem = Item.pLeftBranch
        Case 0:    Exit Do
        Case -1:    pItem = Item.pRightBranch
        End Select
    Loop
    '
    If pItem <> Header.pEndTreePtr Then
        If IsObject(Item.Data) Then
            Set vData = Item.Data
        Else
            vData = Item.Data
        End If
        GetItemByKey = True ' Found it.
    End If
End Function


---

To do it yourself, just throw the above code into a new project's Form1.

This was for rather purely academic pursuits, and my own edification. I really see little, if any, reason someone would use this, as I'm sure just using "vData = Collection.Item(Key)" is much faster. However, it was an interesting pursuit, and truly does unravel the mysteries of the VBA.Collection object.

While doing this, I did also learn that the Collection items are not always in contiguous memory. They often are. However, if you take the above code and bump up the number of random items added (while hopefully not creating a dupe, or putting in a bit of OnErrorResumeNext), you can see this in the immediate window by looking at the pointers. For me, they often skip around in memory. Each item does seem to take 88 (&h58) bytes, which is larger than the VbCollectionItem's structure. And I have no idea why this is.

I thought of writing an AddItemWithKeyToTree procedure (following The Trick's lead), but this would involve allocating memory, and I wasn't up for those details. And "Collection.Add..." works just fine.

To return all the way to the OP #1 post, I'm now convinced that his problems are all to do with idiosyncrasies in "StrComp(str1, str2, vbTextCompare)", and could be discussed entirely outside of any mention of the VBA.Collection.

Best Regards To Everyone,
Elroy

EDIT1: I also snooped around quite a bit in the unknown sections of the VbCollectionHeader. I was hoping to find some StrComp-Compare flag (like the value of vbTextCompare), but I couldn't find anything. It seemed a logical place for it, if it existed, but no cigar (at least from me). Would have been nice though. If I truly want speed and binary keys, I guess I'll have to bite-the-bullet and use the Scripting.Dictionary object.

Elroy,

Code:

---

Option Explicit

Private Declare Function VariantCopyInd Lib "oleaut32.dll" ( _
                        ByRef pvarDest As Any, _
                        ByRef pvargSrc As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" ( _
                        ByRef src As Any, _
                        ByRef Dst As Any) As Long
Private Declare Function VarBstrCmp Lib "oleaut32.dll" ( _
                        ByRef bstrLeft As Any, _
                        ByRef bstrRight As Any, _
                        ByVal lcid As Long, _
                        ByVal dwFlags As Long) As Long

Private Sub Form_Load()
    Dim c As New Collection
   
    c.Add Me, "key 1"
    c.Add 12345, "the trick"
    c.Add "String var", "blabla"
    c.Add 1.43534, "float"
   
    Debug.Print ColItem("key 1", c).Name
    Debug.Print ColItem("the trick", c)
    Debug.Print ColItem("blabla", c)
    Debug.Print ColItem("float", c)
   
End Sub

Private Function ColItem(Key As String, Col As Collection) As Variant
    Dim lpStr As Long, Ptr1 As Long, Ptr2 As Long, sKey As String
 
    GetMem4 ByVal ObjPtr(Col) + 36, Ptr1
    GetMem4 ByVal ObjPtr(Col) + 40, Ptr2
 
    Do Until Ptr1 = Ptr2
        GetMem4 ByVal Ptr1 + 16, lpStr
        Select Case VarBstrCmp(ByVal StrPtr(Key), ByVal lpStr, 1, &H30001)
        Case 0: GetMem4 ByVal Ptr1 + 40, Ptr1
        Case 1
            VariantCopyInd ColItem, ByVal Ptr1
            Exit Function
        Case Else: GetMem4 ByVal Ptr1 + 36, Ptr1
        End Select
    Loop
   
    MsgBox "Element not found"
   
End Function

---

@Trick, very nice!

It's also nice to learn about the VariantCopyInd and VarBstrCmp API functions. The VariantCopyInd is particularly nice. It saves all the gyrations I had to go through to make sure I didn't corrupt memory.


Now I'm wondering if there's an equivalent StringCopyInd function. I searched for that, but didn't find anything. The combination of those two would pretty much solve all the problems of copying a Variant or String into a VB6 variable, when all you have is a pointer.


Best Wishes,
Elroy

Quote:

---

Originally Posted by Elroy

Now I'm wondering if there's an equivalent StringCopyInd function.

---

SysAllocString

@Elroy A lot of API examples use SysReallocString for that.
@The Trick. I see VariantCopyInd used a lot internally, can we assume VariantCopyInd is equivelent to

Code:

---

If IsObject(Value) Then Set Prop = Value Else Prop = Value

---

@Tanner_H

From WinNls.h

Code:

---

//
//  String Flags.
//
#define NORM_IGNORECASE          0x00000001  // ignore case
#define NORM_IGNORENONSPACE      0x00000002  // ignore nonspacing chars
#define NORM_IGNORESYMBOLS        0x00000004  // ignore symbols

#define LINGUISTIC_IGNORECASE    0x00000010  // linguistically appropriate 'ignore case'
#define LINGUISTIC_IGNOREDIACRITIC 0x00000020  // linguistically appropriate 'ignore nonspace'

#define NORM_IGNOREKANATYPE      0x00010000  // ignore kanatype
#define NORM_IGNOREWIDTH          0x00020000  // ignore width
#define NORM_LINGUISTIC_CASING    0x08000000  // use linguistic rules for casing

---

Quote:

---

I haven't used the Microsoft Scripting Runtime that much (scrrun.dll). Can we depend on that being available on all contemporary versions of Windows? (Anyone is welcome to answer this.)

---

I refused using scrrun.dll in projects that require reliable operation because by our statistics 1 of 100 machines surely have problems like damaged reg. info, so, I had to use something like this approach, or class-analogue, like The Trick's one.

Thanks for the info, Dragokas. :)

I was thinking I'd probably stick to the Collection object unless something came up where I just really needed the speed.

Elroy

Quote:

---

Originally Posted by DEXWERX

@The Trick. I see VarCopyInd used a lot internally, can we assume VarCopyInd is equivelent to

Code:

---

If IsObject(Value) Then Set Prop = Value Else Prop = Value

---

---

I don't know that function. There are __vbaVarCopy, __vbaVargVarCopy function from MSVBVM60. VariantCopy(Ind) calls AddRef for object variables.

Quote:

---

If pvargSrc is a VT_DISPATCH or VT_UNKNOWN, AddRef is called to increment the object's reference count.

---

Quote:

---

Originally Posted by The trick

I don't know that function. There are __vbaVarCopy, __vbaVargVarCopy function from MSVBVM60. VariantCopy(Ind) calls AddRef for object variables.

---

ah my bad - I mean VariantCopy(Ind) if any of those can replace the "If IsObject() Then Set" pattern, I'd use it.

@Dex, I started another thread to sort this. You probably already saw it.

@Trick, I'd love to hear your thoughts in the other thread. :)

Elroy

(delete)