Как отсортировать коллекцию на VB6?

@HackerVlad · Регистрация: 10.09.2021

Студворк — интернет-сервис помощи студентам

Как отсортировать коллекцию на VB6? Или как получить отсортированный список данных от коллекции на VB6?

Я недавно нашёл на иностранном форуме очень интересный код для сортировки коллекций, где объясняется что коллекция сама по себе сортируется оказывается (но этого не видно), её ключи, нужно просто уметь правильно вытащить и прочитать эту отсортированную информацию через CopyMemory. До этого я видел только эту тему: А вы задумывались как работает коллекция в VB6?
Но там я не нашёл сортировки. А на иностранном форуме нашёл сортировку. Поэтому хотелось бы поделиться этим.

А так же с помощью этого замечательного кода можно перечислять ключи коллекции, что стандартными средствами VB6 это сделать невозможно (можно только итэмы).

@HackerVlad · 22.02.2025, 19:54 **[ТС]**

Пример, что я прикрепил был скачен с иностранного форума и этот пример, если честно, не очень понятный. Однако есть более простые и понятные примеры. Например вот простой кусок кода для сортировки коллекций (модуль):

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
 
Public Function collSortedKeys(c As Collection, Optional bReverse As Boolean) As String()
    ' Originally written by Wqweto, tweaked by Elroy.
    ' Returns 0 to -1 array on empty Collection.
    ' This is particularly nice when you want to use the Collection for nothing but sorting.
    ' Does NOT return items with no key.
    '
    Dim iRootPtr        As Long
    Dim iEofPtr         As Long
    Dim iCount          As Long
    Dim iFirstOffset    As Long
    Dim iSecondOffset   As Long
    '
    If c Is Nothing Then
        collSortedKeys = Split(vbNullString)
        Exit Function
    End If
    '
    CopyMemory iRootPtr, ByVal PtrAdd(ObjPtr(c), &H24&), 4&
    iEofPtr = EndPointer(c)
    '
    If iRootPtr = iEofPtr Or c.Count = 0 Then
        collSortedKeys = Split(vbNullString)
        Exit Function
    End If
    '
    ' Offsets that determine forward or reverse.
    If Not bReverse Then
        iFirstOffset = &H28&    ' pLeftBranch
        iSecondOffset = &H24&   ' pRightBranch
    Else
        iFirstOffset = &H24&    ' pRightBranch
        iSecondOffset = &H28&   ' pLeftBranch
    End If
    '
    ' Gather the keys.
    ReDim collSortedKeys(1 To c.Count)
    GatherKeysInOrder iRootPtr, iEofPtr, collSortedKeys, iCount, iFirstOffset, iSecondOffset
    If iCount < c.Count Then ReDim Preserve collSortedKeys(1& To iCount)
End Function
 
Private Sub GatherKeysInOrder(ByVal iItemPtr As Long, iEofPtr As Long, sKeysArray() As String, iCount As Long, iFirstOffset As Long, iSecondOffset As Long)
    ' Originally written by Wqweto, tweaked by Elroy.
    Dim iNewPtr         As Long
    Dim sKeyTemp        As String
    '
    ' Traverse left (or right, if reverse) branch if present.
    CopyMemory iNewPtr, ByVal PtrAdd(iItemPtr, iFirstOffset), 4&
    If iNewPtr <> iEofPtr Then GatherKeysInOrder iNewPtr, iEofPtr, sKeysArray, iCount, iFirstOffset, iSecondOffset
    '
    ' Collect current key.
    iCount = iCount + 1&
    CopyMemory ByVal VarPtr(sKeyTemp), ByVal PtrAdd(iItemPtr, &H10&), 4&
    sKeysArray(iCount) = sKeyTemp
    CopyMemory ByVal VarPtr(sKeyTemp), 0&, 4&
    '
    ' Traverse right (or left, if reverse) branch if present.
    CopyMemory iNewPtr, ByVal PtrAdd(iItemPtr, iSecondOffset), 4&
    If iNewPtr <> iEofPtr Then GatherKeysInOrder iNewPtr, iEofPtr, sKeysArray, iCount, iFirstOffset, iSecondOffset
End Sub
 
Private Function PtrAdd(iPtr As Long, iOffset As Long) As Long
    PtrAdd = (iPtr Xor &H80000000) + iOffset Xor &H80000000
End Function
 
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.
    CopyMemory EndPointer, ByVal PtrAdd(ObjPtr(c), &H28&), 4& ' VbCollectionHeader.pEndTreePtr
End Function

Этот пример я сам уже сделал чтобы наглядно было видно как сортируется список.

@HackerVlad · 22.02.2025, 20:00 **[ТС]**

А теперь продолжим тему, из предыдущей темы.

Сообщение от testuser2

Не должно такого быть, положение элементов должно идти в порядке добаления, т.е. добавил "Дерево", потом "Арбуз", "Арбуз" будет 2ым, т.е. иметь индекс 2

Я решил создать этот пример специально для testuser2

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
 
Private Sub GatherKeysInOrder(ByVal iItemPtr As Long, iEofPtr As Long, sKeysArray() As String, iCount As Long, iFirstOffset As Long, iSecondOffset As Long)
    ' Originally written by Wqweto, tweaked by Elroy.
    Dim iNewPtr         As Long
    Dim sKeyTemp        As String
    '
    ' Traverse left (or right, if reverse) branch if present.
    CopyMemory iNewPtr, ByVal PtrAdd(iItemPtr, iFirstOffset), 4&
    If iNewPtr <> iEofPtr Then GatherKeysInOrder iNewPtr, iEofPtr, sKeysArray, iCount, iFirstOffset, iSecondOffset
    '
    ' Collect current key.
    iCount = iCount + 1&
    CopyMemory ByVal VarPtr(sKeyTemp), ByVal PtrAdd(iItemPtr, &H10&), 4&
    sKeysArray(iCount) = sKeyTemp
    CopyMemory ByVal VarPtr(sKeyTemp), 0&, 4&
    '
    ' Traverse right (or left, if reverse) branch if present.
    CopyMemory iNewPtr, ByVal PtrAdd(iItemPtr, iSecondOffset), 4&
    If iNewPtr <> iEofPtr Then GatherKeysInOrder iNewPtr, iEofPtr, sKeysArray, iCount, iFirstOffset, iSecondOffset
End Sub
 
Private Function PtrAdd(iPtr As Long, iOffset As Long) As Long
    PtrAdd = (iPtr Xor &H80000000) + iOffset Xor &H80000000
End Function
 
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.
    CopyMemory EndPointer, ByVal PtrAdd(ObjPtr(c), &H28&), 4& ' VbCollectionHeader.pEndTreePtr
End Function
 
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
 
Public Function collSortedKeys(c As Collection, Optional bReverse As Boolean) As String()
    ' Originally written by Wqweto, tweaked by Elroy.
    ' Returns 0 to -1 array on empty Collection.
    ' This is particularly nice when you want to use the Collection for nothing but sorting.
    ' Does NOT return items with no key.
    '
    Dim iRootPtr        As Long
    Dim iEofPtr         As Long
    Dim iCount          As Long
    Dim iFirstOffset    As Long
    Dim iSecondOffset   As Long
    '
    If c Is Nothing Then
        collSortedKeys = Split(vbNullString)
        Exit Function
    End If
    '
    CopyMemory iRootPtr, ByVal PtrAdd(ObjPtr(c), &H24&), 4&
    iEofPtr = EndPointer(c)
    '
    If iRootPtr = iEofPtr Or c.Count = 0 Then
        collSortedKeys = Split(vbNullString)
        Exit Function
    End If
    '
    ' Offsets that determine forward or reverse.
    If Not bReverse Then
        iFirstOffset = &H28&    ' pLeftBranch
        iSecondOffset = &H24&   ' pRightBranch
    Else
        iFirstOffset = &H24&    ' pRightBranch
        iSecondOffset = &H28&   ' pLeftBranch
    End If
    '
    ' Gather the keys.
    ReDim collSortedKeys(1 To c.Count)
    GatherKeysInOrder iRootPtr, iEofPtr, collSortedKeys, iCount, iFirstOffset, iSecondOffset
    If iCount < c.Count Then ReDim Preserve collSortedKeys(1& To iCount)
End Function
 
' Стандартными средствами VB6 возможно только перечислить список итэмов коллекции (но не ключей)
' А этот код для того чтобы сделать невозможное: отобразить список именно ключей коллекции
Public Function collAllKeys(c As Collection) As String()
    ' This one actually DOES return vbNullString keys.
    ' Returns 0 to -1 array on empty Collection.
    '
    Dim iArray      As Long
    Dim iItemPtr    As Long
    Dim sKeyTemp    As String
    '
    If c Is Nothing Then
        collAllKeys = Split(vbNullString)
        Exit Function
    End If
    If c.Count = 0 Then
        collAllKeys = Split(vbNullString)
        Exit Function
    End If
    '
    ReDim collAllKeys(1 To c.Count)
    iItemPtr = ObjPtr(c)                                                        ' This works because the offset in the header is also &H18.
    For iArray = 1& To c.Count
        CopyMemory iItemPtr, ByVal PtrAdd(iItemPtr, &H18&), 4&                  ' First/Next item pointer of collection item.
        CopyMemory ByVal VarPtr(sKeyTemp), ByVal PtrAdd(iItemPtr, &H10&), 4&    ' Key string of collection item.
        LetStringArray collAllKeys, iArray, sKeyTemp                            ' Move key into array.
    Next iArray
    '
    ' Mandatory cleanup, put string pointer back to keep memory straight.
    CopyMemory ByVal VarPtr(sKeyTemp), 0&, 4&
End Function
 
Private Sub Command1_Click()
    Dim tree As New Collection
    Dim sortedStrs() As String
    Dim treeKeys() As String
    Dim i As Integer
    
    tree.Add "Строка 1", "Дерево"
    tree.Add "Строка 2", "Арбуз"
    tree.Add "Строка 3", "Банан"
    
    sortedStrs = collSortedKeys(tree) ' Получаем отсортированную коллекцию
    treeKeys = collAllKeys(tree)
    
    ' Осуществляем невозможное: перечисляем список КЛЮЧЕЙ коллекции
    For i = 1 To UBound(treeKeys)
        Debug.Print treeKeys(i)
    Next
    
    ' Печать всех элементов, используя For Each (стандартные средства VB6 позволяют перечислять только итэмы, но не ключи коллекции)
    Dim trees As Variant
    
    For Each trees In tree
        Print trees
    Next
    
    ' Печатаем на форме отсортированный список (арбуз будет на 1 месте теперь)
    Print "---"
    
    For i = 1 To UBound(sortedStrs)
        Print sortedStrs(i)
    Next
End Sub

@testuser2 · 23.02.2025, 10:02

Сообщение от HackerVlad

Private Function PtrAdd(iPtr As Long, iOffset As Long) As Long
PtrAdd = (iPtr Xor &H80000000) + iOffset Xor &H80000000
End Function

Вот это я не понял чёзанах, по моему это не обязательно, надо просто прибавлять смещение.

Добавлено через 21 минуту

Сообщение от HackerVlad

' Осуществляем невозможное: перечисляем список КЛЮЧЕЙ коллекции

Уже делалось миной Как получить название ключа в коллекции

Добавлено через 4 минуты

Сообщение от HackerVlad

~~CopyMemory iNewPtr, ByVal PtrAdd(iItemPtr, iFirstOffset), 4&~~

Visual Basic
1
2
3
CopyMemory iNewPtr, ByVal iItemPtr + iFirstOffset, 4&
'или
GetMem4 ByVal iItemPtr + iFirstOffset, iNewPtr

Добавлено через 27 минут

Сообщение от HackerVlad

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

Это тоже не нужное изобретение, когда функции нужно возвратить массив, просто создаем временный массив и заполняем его, а в конце присваиваем этот массив переменной функции, при этом происходит не обычное копирование массива, а перемещение указателя.

Сообщение от HackerVlad

Dim iArray As Long

тоже берд, целочисленную переменную назвать iArray )

Добавлено через 3 часа 27 минут
Это кстати прикольно, когда смотришь код, где Wqweto и Elroy там фигню какую-то нагородили, и можно посидеть поисправлять, чсв-шку свою потешить ))

@HackerVlad · 23.02.2025, 13:19 **[ТС]**

Сообщение от testuser2

Уже делалось миной

Я не знал, что ты настолько продвинутый программист))) Я такое делать не умею такие крутые вещи - это всё содрано. wqweto по моему писал этот код.

Добавлено через 1 минуту

Сообщение от testuser2

Это кстати прикольно, когда смотришь код, где Wqweto и Elroy там фигню какую-то нагородили, и можно посидеть поисправлять, чсв-шку свою потешить ))

Так это же классно! Если ты можешь сделать лучше чем у них то сделай пожалуйста, поисправляй их ляпы.

@testuser2 · 23.02.2025, 14:52

Убрал лишнее (должно быть в обычном модуле)

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
Option Explicit
Private Declare Sub CopyPtr Lib "kernel32" Alias "RtlMoveMemory" ( _
        Dst As Any, Src As Any, Optional ByVal ln As Long = 4)
'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal ByteLen As Long)
'Private Declare Function MovePtr Lib "msvbvm60" Alias "__vbaAryMove" ( _
        pDst As Long, ByVal pSrc As Long) As Long
Private Const KeyOffset As Long = &H10&
Private Const NxtOffset As Long = &H18
Private Const RgtOffset As Long = &H24
Private Const LftOffset As Long = &H28
Private Offset1 As Long, Offset2 As Long, pEOF As Long, lCnt As Long
 
Private Sub GatherKeysInOrder(ByVal pItem As Long, sKeys() As String)
    ' Originally written by Wqweto, tweaked by Elroy and Testuser2(2025)
    Dim pNewItem    As Long
    Dim sKey        As String
    Dim pKey        As Long
    ' Traverse left (or right, if reverse) branch if present.
    CopyPtr pNewItem, ByVal pItem + Offset1
    If pNewItem <> pEOF Then GatherKeysInOrder pNewItem, sKeys
    
    ' Collect current key.
    lCnt = lCnt + 1&
    pKey = VarPtr(sKey)
    CopyPtr ByVal pKey, ByVal pItem + &H10&
    sKeys(lCnt) = sKey
    CopyPtr ByVal pKey, 0&
    
    ' Traverse right (or left, if reverse) branch if present.
    CopyPtr pNewItem, ByVal pItem + Offset2
    If pNewItem <> pEOF Then GatherKeysInOrder pNewItem, sKeys
End Sub
 
Public Function collSortedKeys(coll As Collection, Optional ByVal blReverse As Boolean) As String()
    ' Originally written by Wqweto, tweaked by Elroy.
    ' Returns 0 to -1 array on empty Collection.
    ' This is particularly nice when you want to use the Collection for nothing but sorting.
    ' Does NOT return items with no key.    '
    Dim pRoot As Long
    Select Case True
    Case coll Is Nothing, coll.Count = 0: Exit Function
    End Select
    
    CopyPtr pRoot, ByVal ObjPtr(coll) + RgtOffset
    CopyPtr pEOF, ByVal ObjPtr(coll) + LftOffset 'pEOF = EndPointer(c)
    
    If pRoot = pEOF Then Exit Function
    
    ' Offsets that determine forward or reverse.
    If Not blReverse Then
        Offset1 = LftOffset     ' pLeftBranch
        Offset2 = RgtOffset     ' pRightBranch
    Else
        Offset1 = RgtOffset     ' pRightBranch
        Offset2 = LftOffset     ' pLeftBranch
    End If
    
    ' Gather the keys.
    ReDim collSortedKeys(1 To coll.Count)
    GatherKeysInOrder pRoot, collSortedKeys
    If lCnt < coll.Count Then ReDim Preserve collSortedKeys(1 To lCnt)
    lCnt = 0
End Function
 
' Стандартными средствами VB6 возможно только перечислить список итэмов коллекции (но не ключей)
' А этот код для того чтобы сделать невозможное: отобразить список именно ключей коллекции
Public Function collAllKeys(coll As Collection) As String()
    ' This one actually DOES return vbNullString keys.
    ' Returns 0 to -1 array on empty Collection.
    Dim i           As Long
    Dim pItem       As Long
    Dim sKeyTmp     As String
    Dim psKeyTmp    As Long
    Dim sKeys()     As String
    Dim cCnt        As Long
    If coll Is Nothing Then Exit Function
    cCnt = coll.Count
    If cCnt = 0 Then Exit Function
    
    ReDim sKeys(1 To cCnt)
    pItem = ObjPtr(coll)                    ' This works because the offset in the header is also &H18.
    psKeyTmp = VarPtr(sKeyTmp)
    For i = 1& To cCnt
        CopyPtr pItem, ByVal pItem + NxtOffset          ' First/Next item pointer of collection item.
        CopyPtr ByVal psKeyTmp, ByVal pItem + KeyOffset ' Key string of collection item.
        sKeys(i) = sKeyTmp                              ' Copy key into array.
    Next
    
    ' Mandatory cleanup, put string pointer back to keep memory straight.
    CopyPtr ByVal psKeyTmp, 0&
    
    collAllKeys = sKeys
End Function
 
Private Sub TestCollSortedKeys()
    Dim tree As New Collection
    Dim sortedStrs() As String
    Dim treeKeys() As String
    Dim i As Long
    
    tree.Add "Строка 1", "Дерево"
    tree.Add "Строка 2", "Арбуз"
    tree.Add "Строка 3", "Банан"
    
    sortedStrs = collSortedKeys(tree) ' Получаем отсортированную коллекцию
    treeKeys = collAllKeys(tree)
    
    ' Осуществляем невозможное: перечисляем список КЛЮЧЕЙ коллекции
    For i = 1 To UBound(treeKeys)
        Debug.Print treeKeys(i)
    Next
    
    ' Печать всех элементов, используя For Each (стандартные средства VB6 позволяют перечислять только итэмы, но не ключи коллекции)
    Dim trees As Variant
    
    For Each trees In tree
        Print trees
    Next
    
    ' Печатаем на форме отсортированный список (арбуз будет на 1 месте теперь)
    Print "---"
    
    For i = 1 To UBound(sortedStrs)
        Print sortedStrs(i)
    Next
End Sub

Добавлено через 3 минуты
Еще один вариант сделал чтобы лучше понять как это работает, но все-равно не понял, надо визуализацию дерева чтобы понять. Кстати визуализацию красно-черного дерева не трудно найти в интернете.

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
Option Explicit
Declare Sub GetMem4 Lib "msvbvm60" (ByRef Src As Any, ByRef Dst As Any)
Declare Sub GetMem8 Lib "msvbvm60" (Src As Any, Dst As Any)
Private Declare Function VirtualProtect Lib "kernel32" ( _
    ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
'Private Declare Sub CopyPtr Lib "kernel32" Alias "RtlMoveMemory" ( _
        Dst As Any, Src As Any, Optional ByVal ln As Long = 4)
'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal ByteLen As Long)
'Private Declare Function MovePtr Lib "msvbvm60" Alias "__vbaAryMove" ( _
        pDst As Long, ByVal pSrc As Long) As Long
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Type tColItem
    vVal As Variant 'значение итема
    sKey As String  'ключ итема
    pPrev As Long   'предыдущий итем в обычном порядке
    pNxt As Long    'следующий итем в обычном порядке
    unuse2(1) As Long
    pRgt As Long    'Правый итем с бОльшим значением ключа
    pLft As Long    'Левый итем с меньшим значением ключа
End Type
Private Enum CollItemOffsets
    KeyOffset = &H10&
    NxtOffset = &H18
    RgtOffset = &H24
    LftOffset = &H28
End Enum
Private Offset1 As CollItemOffsets, Offset2 As CollItemOffsets, pEOF As Long, lCnt As Long
Sub testCollItem()
    Dim ci As tColItem
    Dim pci As Long: pci = VarPtr(ci)
    Debug.Print Hex(VarPtr(ci.sKey) - pci)
    Debug.Print Hex(VarPtr(ci.pNxt) - pci)
    Debug.Print Hex(VarPtr(ci.pRgt) - pci)
    Debug.Print Hex(VarPtr(ci.pLft) - pci)
End Sub
Private Sub GatherKeysInOrder(ByVal pItem As Long, sKeys() As String)
    ReplaceFunPtr AddressOf GatherKeysInOrder, AddressOf GatherKeysInOrder_
    GatherKeysInOrder pItem, sKeys()
End Sub
Private Sub GatherKeysInOrder_(tItem As tColItem, sKeys() As String)
    ' Originally written by Wqweto, tweaked by Elroy and Testuser2(2025)
    Dim pNewItem    As Long
    Dim pItem As Long: pItem = VarPtr(tItem)
    Stop
    GetMem4 ByVal pItem + Offset1, pNewItem ' Traverse left (or right, if reverse) branch if present.
'    pNewItem = tItem.pLft
    If pNewItem <> pEOF Then GatherKeysInOrder pNewItem, sKeys
    
    lCnt = lCnt + 1&
    sKeys(lCnt) = tItem.sKey
    
    ' Traverse right (or left, if reverse) branch if present.
    GetMem4 ByVal pItem + Offset2, pNewItem
    If pNewItem <> pEOF Then GatherKeysInOrder pNewItem, sKeys
End Sub
 
Private Function collSortedKeys(coll As Collection, Optional ByVal blReverse As Boolean) As String()
    ' Originally written by Wqweto, tweaked by Elroy.
    ' Returns 0 to -1 array on empty Collection.
    ' This is particularly nice when you want to use the Collection for nothing but sorting.
    ' Does NOT return items with no key.    '
    Dim pRoot As Long
    Select Case True
    Case coll Is Nothing, coll.Count = 0: Exit Function
    End Select
    
    GetMem4 ByVal ObjPtr(coll) + RgtOffset, pRoot   
    GetMem4 ByVal ObjPtr(coll) + LftOffset, pEOF   
    
    If pRoot = pEOF Then Exit Function
    
    ' Offsets that determine forward or reverse.
    If Not blReverse Then
        Offset1 = LftOffset     ' pLeftBranch
        Offset2 = RgtOffset     ' pRightBranch
    Else
        Offset1 = RgtOffset     ' pRightBranch
        Offset2 = LftOffset     ' pLeftBranch
    End If
    
    ' Gather the keys.
    ReDim collSortedKeys(1 To coll.Count)
    GatherKeysInOrder pRoot, collSortedKeys
    If lCnt < coll.Count Then ReDim Preserve collSortedKeys(1 To lCnt)
    lCnt = 0
End Function
 
' Стандартными средствами VB6 возможно только перечислить список итэмов коллекции (но не ключей)
' А этот код для того чтобы сделать невозможное: отобразить список именно ключей коллекции
Private Function collAllKeys(coll As Collection) As String()
    ' This one actually DOES return vbNullString keys.
    ' Returns 0 to -1 array on empty Collection.
    Dim i           As Long
    Dim pItem       As Long
    Dim sKeyTmp     As String
    Dim psKeyTmp    As Long
    Dim sKeys()     As String
    Dim cCnt        As Long
    If coll Is Nothing Then Exit Function
    cCnt = coll.Count
    If cCnt = 0 Then Exit Function
    
    ReDim sKeys(1 To cCnt)
    pItem = ObjPtr(coll)                    ' This works because the offset in the header is also &H18.
    psKeyTmp = VarPtr(sKeyTmp)
    For i = 1& To cCnt
        GetMem4 ByVal pItem + NxtOffset, pItem          ' First/Next item pointer of collection item.
        GetMem4 ByVal pItem + KeyOffset, ByVal psKeyTmp ' Key string of collection item.
        sKeys(i) = sKeyTmp                              ' Copy key into array.
    Next
    
    ' Mandatory cleanup, put string pointer back to keep memory straight.
    GetMem4 0&, ByVal psKeyTmp 
    
    collAllKeys = sKeys
End Function
 
'Процедура подмены указателя одной функции на другую
'Based on this patch by The trick: https://www.cyberforum.ru/visual-basic/thread1150127-page3.html#post8172932
Sub ReplaceFunPtr(ByVal AddrDst As Long, ByVal AddrSrc As Long)
    Dim InIDE As Boolean
    Debug.Assert MakeTrue(InIDE)
    If InIDE Then
        GetMem4 ByVal AddrDst + &H16, AddrDst
        GetMem4 ByVal AddrSrc + &H16, AddrSrc
    Else
        VirtualProtect AddrDst, 8, PAGE_EXECUTE_READWRITE, 0
    End If
    Dim b(7) As Byte
    GetMem8 ByVal AddrSrc, b(0)
    GetMem8 ByVal AddrSrc, ByVal AddrDst
End Sub
Function MakeTrue(ByRef blVar As Boolean) As Boolean
    blVar = True: MakeTrue = True
End Function
 
Sub TestCollSortedKeys2()
    Dim tree As New Collection
    Dim sortedStrs() As String
    Dim treeKeys() As String
    Dim i As Long
    
    tree.Add "Строка 1", "Дерево"
    tree.Add "Строка 2", "Арбуз"
    tree.Add "Строка 3", "Банан"
    
    sortedStrs = collSortedKeys(tree) ' Получаем отсортированную коллекцию
    treeKeys = collAllKeys(tree)
    
    ' Осуществляем невозможное: перечисляем список КЛЮЧЕЙ коллекции
    For i = 1 To UBound(treeKeys)
        Debug.Print treeKeys(i)
    Next
    
    ' Печатаем на форме отсортированный список (арбуз будет на 1 месте теперь)
    Debug.Print "---"
    
    For i = 1 To UBound(sortedStrs)
        Debug.Print sortedStrs(i)
    Next
End Sub

@HackerVlad · 23.02.2025, 14:58 **[ТС]**

Сообщение от testuser2

красно-черного

Я если честно то вообще не втимяшил что такое красно-чёрное дерево. И почему оно красное и чёрное? Бредятина а не название.

Добавлено через 1 минуту
testuser2, листья на деревьях зелёные а ствол дерева коричневый, поэтому я хз как понимать красно-чёрное дерево...

@testuser2 · 23.02.2025, 16:24

В Твин-бейсике добавили функционалу коллекции, но ключ по прежнему только строковый, Remove только по индексу и, кстати, нету функции Sort.. а могла бы быть

Нету ссылки на последний итем, первый, на меньший/больший..

Добавлено через 1 минуту

Сообщение от HackerVlad

листья на деревьях зелёные а ствол дерева коричневый, поэтому я хз как понимать красно-чёрное дерево...

У тех, кто это придумывал были только черная и красная ручка на столе (из Вики) так оно и зародилось

@HackerVlad · 23.02.2025, 17:10 **[ТС]**

testuser2, ну теперь ты понимаешь что я тебя не обманывал, на счёт того что коллекция сама по себе сортированная только никто этого не видит!? а этот код достаёт невидимую сортировку как бы. Поэтому будет работать быстрее этот код чем все остальные аналоги которые сортируют коллекцию в VBA не важно какими методами сортировки они будут пользоваться Merge или ещё какими-нибудь они все будут как бы сортировать второй раз и поэтому будет медленее а коллекция она сама по себе уже отсортирована просто никто об этом не знает. И я об этом не знал

@testuser2 · 23.02.2025, 17:50

Интересная фишка, можно одновременно уникальные строки отбирать и сортировать пропуск ошибок только напрягает слегка. Вообще коллекция быстрее быстрее словаря ищет итем по ключу на больших колличествах (более 100 тыс.), потому что у dictionary размер хэш-таблицы ограничен.

@HackerVlad · 23.02.2025, 18:27 **[ТС]**

testuser2, ну вот видишь, а ты был против коллекций

@The trick · 23.02.2025, 21:33

Сообщение от testuser2

Вообще коллекция быстрее быстрее словаря ищет итем по ключу на больших колличествах (более 100 тыс.), потому что у dictionary размер хэш-таблицы ограничен.

Ну хэш таблица в общем случае должна быть быстрее там среднее время доступа O(1).

@testuser2 · 24.02.2025, 02:13

Я, кстати, думал, что красно-черное просто заполняется и если там добавлять все время в порядке сортировки(1, 2, 3, 4..), должна выстроиться одна длинная ветвь, но вот сейчас на визуалке смотрю, не так просто там, оно балансируется (перестраивается), и даже корень там может периодически меняться. А это еще наверноое надо, учитывать при удалении элемента..

Сообщение от HackerVlad

а ты был против коллекций

Я не против самой концепции логического дерева, но, почему-то функционала маловато добавили в коллекцию, хотя можно было

Добавлено через 5 минут

Не по теме:

Сообщение от HackerVlad

прочитал на иностранном форуме.

Зачем про какие-то иностранный форум пишешь, тут у нас хорошо и так )

@Catstail · 24.02.2025, 15:16

Сообщение от HackerVlad

Я если честно то вообще не втимяшил что такое красно-чёрное дерево. И почему оно красное и чёрное? Бредятина а не название.

- очень зря... Популярнейшая структура данных

@HackerVlad · 24.02.2025, 16:02 **[ТС]**

testuser2, ну вот видишь, а ты был против коллекций

Сообщение от Catstail

очень зря

ну прочитал но там всё равно ничего не понятно

@Catstail · 25.02.2025, 05:39

Сообщение от HackerVlad

ну прочитал но там всё равно ничего не понятно

- и кто виноват?

Ну, прочитай что-либо другое на эту тему. Кстати, кроме красно-чёрных есть еще AVL-деревья, B и B+ деревья, префиксные деревья...

@Catstail · 25.02.2025, 13:43

Сообщение от testuser2

красно-черное просто заполняется и если там добавлять все время в порядке сортировки(1, 2, 3, 4..), должна выстроиться одна длинная ветвь

- так в этом и суть! А без балансировки получится простое дерево поиска (которое может выродиться в список).

@HackerVlad · 25.02.2025, 14:40 **[ТС]**

Catstail, почему вы больше не модератор в vb6?

@Catstail · 25.02.2025, 14:53

HackerVlad, я остался модератором. Только теперь могу модерировать все разделы.

@testuser2 · 25.02.2025, 14:56

Сообщение от Catstail

- так в этом и суть! А без балансировки получится простое дерево поиска (которое может выродиться в список).

Да уж не просто там все. Даже с визуалом как-то не заходит )

Новые блоги и статьи Все статьи Все блоги /
Подключение Box2D v3 к SDL3 для Android: физика и отрисовка коллайдеров 8Observer8 29.01.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами. Версия v3 была полностью переписана на Си, в. . .	Инструменты COM: Сохранение данный из VARIANT в файл и загрузка из файла в VARIANT bedvit 28.01.2026 Сохранение базовых типов COM и массивов (одномерных или двухмерных) любой вложенности (деревья) в файл, с возможностью выбора алгоритмов сжатия и шифрования. Часть библиотеки BedvitCOM Использованы. . .	Загрузка PNG с альфа-каналом на SDL3 для Android: с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 28.01.2026 Содержание блога SDL3 имеет собственные средства для загрузки и отображения PNG-файлов с альфа-каналом и базовой работы с ними. В этой инструкции используется функция SDL_LoadPNG(), которая. . .	Загрузка PNG с альфа-каналом на SDL3 для Android: с помощью SDL3_image 8Observer8 27.01.2026 Содержание блога SDL3_image - это библиотека для загрузки и работы с изображениями. Эта пошаговая инструкция покажет, как загрузить и вывести на экран смартфона картинку с альфа-каналом, то есть с. . .
Влияние грибов на сукцессию anaschu 26.01.2026 Бифуркационные изменения массы гриба происходят тогда, когда мы уменьшаем массу компоста в 10 раз, а скорость прироста биомассы уменьшаем в три раза. Скорость прироста биомассы может уменьшаться за. . .	Воспроизведение звукового файла с помощью SDL3_mixer при касании экрана Android 8Observer8 26.01.2026 Содержание блога SDL3_mixer - это библиотека я для воспроизведения аудио. В отличие от инструкции по добавлению текста код по проигрыванию звука уже содержится в шаблоне примера. Нужно только. . .	Установка Android SDK, NDK, JDK, CMake и т.д. 8Observer8 25.01.2026 Содержание блога Перейдите по ссылке: https:/ / developer. android. com/ studio и в самом низу страницы кликните по архиву "commandlinetools-win-xxxxxx_latest. zip" Извлеките архив и вы увидите. . .	Вывод текста со шрифтом TTF на Android с помощью библиотеки SDL3_ttf 8Observer8 25.01.2026 Содержание блога Если у вас не установлены Android SDK, NDK, JDK, и т. д. то сделайте это по следующей инструкции: Установка Android SDK, NDK, JDK, CMake и т. д. Сборка примера Скачайте. . .

@HackerVlad Испарился 1741 / 637 / 45 Регистрация: 10.09.2021 Сообщений: 2,769
	23.02.2025, 17:10 [ТС]
	testuser2, ну теперь ты понимаешь что я тебя не обманывал, на счёт того что коллекция сама по себе сортированная только никто этого не видит!? а этот код достаёт невидимую сортировку как бы. Поэтому будет работать быстрее этот код чем все остальные аналоги которые сортируют коллекцию в VBA не важно какими методами сортировки они будут пользоваться Merge или ещё какими-нибудь они все будут как бы сортировать второй раз и поэтому будет медленее а коллекция она сама по себе уже отсортирована просто никто об этом не знает. И я об этом не знал 0

@testuser2 1385 / 840 / 91 Регистрация: 08.02.2017 Сообщений: 3,567 Записей в блоге: 1
	23.02.2025, 17:50
	Интересная фишка, можно одновременно уникальные строки отбирать и сортировать пропуск ошибок только напрягает слегка. Вообще коллекция быстрее быстрее словаря ищет итем по ключу на больших колличествах (более 100 тыс.), потому что у dictionary размер хэш-таблицы ограничен. 1

@HackerVlad Испарился 1741 / 637 / 45 Регистрация: 10.09.2021 Сообщений: 2,769
	23.02.2025, 18:27 [ТС]
	testuser2, ну вот видишь, а ты был против коллекций 0

@HackerVlad Испарился 1741 / 637 / 45 Регистрация: 10.09.2021 Сообщений: 2,769
	25.02.2025, 14:40 [ТС]
	Catstail, почему вы больше не модератор в vb6? 0

@Catstail Супер-модератор 38169 / 21104 / 4307 Регистрация: 12.02.2012 Сообщений: 34,693 Записей в блоге: 14
	25.02.2025, 14:53
	HackerVlad, я остался модератором. Только теперь могу модерировать все разделы. 0