Версия для печати
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум на Исходниках.RU > Visual Basic: Общие вопросы > А вы задумывались как работает коллекция в VB6?


Автор: TheTrik 24.06.18, 07:15
Всем привет.
Решил пореверсить коллекции. Выяснилось что это двоичное красно-черное дерево, все смещения в классах соответствуют смещениям в оригинальной коллекции (можете заменять на структуры и смело обращаться по указателю, меняя данные). Реализованы не все методы, но для понимания алгоритма работы - это не требуется.
Сама коллекция CVBCollection:
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    ' //
    ' // 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

Элемент коллекции CVBCollectionItem:
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
    ' //
    ' // 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

Powered by Invision Power Board (https://www.invisionboard.com)
© Invision Power Services (https://www.invisionpower.com)