А вы задумывались как работает коллекция в VB6?

Автор обещает много интересных штучек.

Модератор: The trick

The trick
Постоялец
Постоялец
 
Сообщения: 774
Зарегистрирован: 26.06.2010 (Сб) 23:08

А вы задумывались как работает коллекция в VB6?

Сообщение The trick » 14.03.2017 (Вт) 23:49

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

Вернуться в The trick

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 5

    TopList