На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! Правила раздела Visual Basic: Общие вопросы
Здесь обсуждаются вопросы по языку Visual Basic 1-6 (а так же по схожим языкам, как, например, PowerBASIC).
Вопросы по Visual Basic .NET (это который входит в состав Visual Studio 2002/2003/2005/2008+, для тех, кто не в курсе) обсуждаются в разделе .NET.

Обратите внимание:
1. Прежде чем начать новую тему или отправить сообщение, убедитесь, что Вы не нарушаете правил форума!
2. Обязательно воспользуйтесь поиском. Возможно, Ваш вопрос уже обсуждали. Полезные ссылки приведены ниже.
3. Темы с просьбой выполнить какую-либо работу за автора в этом разделе не обсуждаются. Студенты, вам сюда: ПОМОЩЬ СТУДЕНТАМ!
4. Используйте теги [ code=vba ] ...текст программы... [ /code ] для выделения текста программы подсветкой.
5. Помните, здесь телепатов нет. Формулируйте свой вопрос максимально грамотно и чётко: Как правильно задавать вопросы
6. Запрещено отвечать в темы месячной (и более) давности, без веских на то причин.

Полезные ссылки:
user posted image FAQ Сайта user posted image FAQ Раздела user posted image Кладовка user posted image Наши Исходники user posted image API-Guide user posted image Поиск по Разделу user posted image MSDN Library Online user posted image Google

Ваше мнение о модераторах: user posted image SCINER, user posted image B.V.
Модераторы: SCINER, B.V.
  
> А вы задумывались как работает коллекция в VB6? , Внутренняя структура коллекции (Collection)
    Всем привет.
    Решил пореверсить коллекции. Выяснилось что это двоичное красно-черное дерево, все смещения в классах соответствуют смещениям в оригинальной коллекции (можете заменять на структуры и смело обращаться по указателю, меняя данные). Реализованы не все методы, но для понимания алгоритма работы - это не требуется.
    Сама коллекция CVBCollection:
    ExpandedWrap disabled
      ' //
      ' // 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:
    ExpandedWrap disabled
      ' //
      ' // 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
    0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
    0 пользователей:


    Рейтинг@Mail.ru
    [ Script execution time: 0,0324 ]   [ 17 queries used ]   [ Generated: 28.03.24, 17:43 GMT ]