Сортировка словаря методом реконструкции

Option Explicit
'
'Сортировка словаря !
'© FelixMacintosh (Антихакер32™)
'
Const Elements = 100
Dim Dic1 As Object
Dim Dic2 As Object
Dim WithEvents Picture1 As PictureBox
Dim WithEvents Picture2 As PictureBox
Dim WithEvents Command1 As CommandButton
 
Private Sub Command1_Click()
    Const r = vbNullChar & "[Разделяющее значение]" & vbNullChar
    Dim Keys, j$(), f&, v As Variant, p(1) As PictureBox
    CreateDictionary
    Keys = Dic1.Keys
    For f = 0 To Dic1.Count - 1
        Keys(f) = Keys(f) & r & Dic1.Item(Keys(f))
    Next
    Call SortStr(Keys, Dic1.CompareMode, 0, UBound(Keys))
    Dic2.RemoveAll
    For f = 0 To Dic1.Count - 1
        j = Split(Keys(f), r)
        Dic2.Add j(0), j(1)
    Next
    '---------------------------------------------------------------------------------------
    Set p(0) = Picture1: Set p(1) = Picture2
    For f = 0 To 1: p(f).Cls: Next
    For f = 0 To 1: p(f).BackColor = "&H80000009": Next
    p(0).Print vbTab; "Исходный список Dic1"
    p(1).Print vbTab; "Отсортированный список Dic2"
    For f = 0 To 1: p(f).Print String(1000, "."): Next
    For Each v In Dic1
        Picture1.Print vbTab; v; vbTab; , "="; vbTab; Dic1(v)
    Next
    For Each v In Dic2 'Абсолютное соответствие !
        Picture2.Print vbTab; v; vbTab; , "="; vbTab; Dic2(v); vbTab; "Dic1(" & v & ") = " & Dic1(v)
    Next
End Sub
 
Private Sub Form_Initialize()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.CompareMode = 1
    Set Dic2 = CreateObject("Scripting.Dictionary")
    Dic2.CompareMode = 1
End Sub
 
Private Sub Form_Load()
    Set Picture1 = Controls.Add("VB.PictureBox", "Picture1")
    Set Picture2 = Controls.Add("VB.PictureBox", "Picture2")
    Set Command1 = Controls.Add("VB.CommandButton", "Command1")
    Picture1.Visible = True: Picture2.Visible = True
    Command1.Caption = "Запустить !"
    Command1.Visible = True
End Sub
 
Private Sub Form_Resize()
    Const c1 = 5, c2 = 20
    Dim twx&, w1&
    twx = c1 * Screen.TwipsPerPixelX
    Me.WindowState = 2
    w1 = Me.ScaleWidth / 2
    Picture1.Move 0, 0, w1, Me.ScaleHeight
    Picture2.Move w1 + twx, 0, w1 - twx, Me.ScaleHeight
    Command1.Move w1 - c2 * twx, 0, c2 * twx, c1 * twx
    Command1.ZOrder 0
End Sub
 
Private Sub CreateDictionary()
 
    Dim s$, j$(), f&, f1&, i&
    Randomize Timer
    s = vbNullString
    For f = 1 To Elements
        For f1 = 1 To 1 + Fix(Rnd * 10)
            s = s & Chr(65 + Fix(Rnd * 26))
            i = i + 1: Mid(s, i, 1) = IIf(Fix(Rnd * 2), UCase(Mid(s, i, 1)), LCase(Mid(s, i, 1)))
        Next
        s = s & " ": i = i + 1
    Next
    j = Split(s): ReDim Preserve j(UBound(j) - 1)
    
    Dic1.RemoveAll
    For f = 0 To UBound(j)
        While Dic1.Exists(j(f))
            s = "": i = 0
            For f1 = 1 To 1 + Fix(Rnd * 10)
                s = s & Chr(65 + Fix(Rnd * 26))
                i = i + 1: Mid(s, i, 1) = IIf(Fix(Rnd * 2), UCase(Mid(s, i, 1)), LCase(Mid(s, i, 1)))
            Next
            j(f) = s
        Wend
        Dic1.Add j(f), f
    Next
End Sub
 
Private Sub SortStr(List As Variant, Compare&, Min&, Max&)
    'Рекурсивный алгоритм быстрой сортировки
    Dim i1&, i2&, n&, s$
    If Not IsArray(List) Then Err.Raise 13
    If Max - Min < 1 Then Exit Sub 'Пройден весь список
    n = Fix((Max - Min + 1) / 5 + Min) 'Выбрать разделяющее значение.
    s = List(n)
    List(n) = List(Min) 'Переместить его вперед.
    i1 = Min: i2 = Max
 
    Do
 
        While StrComp(List(i2), s, Compare) >= 0 'Просмотр сверху вниз от i2 до значения >= s
            i2 = i2 - 1
            If i2 <= i1 Then List(i1) = s: Exit Do
        Wend
        List(i1) = List(i2) 'Поменять местами значения i1 и i2.
        '-----------
        i1 = i1 + 1 'Просмотр снизу вверх от i1 до значения < s.
 
        While StrComp(List(i1), s, Compare) < 0
            i1 = i1 + 1
            If i1 >= i2 Then i1 = i2: List(i2) = s: Exit Do
        Wend
        List(i2) = List(i1) 'Поменять местами значения i1 и i2.
    Loop
    '---------------------------------Сортировать два подсписка.
    On Error GoTo 1
 
    While List(i1) = List(i1 - 1) 'Сокращение диапазона поиска для Max
        i1 = i1 - 1
    Wend
    SortStr List, Compare, Min, i1
    
1
    On Error GoTo 2
 
    While List(i1) = List(i1 + 1) 'Сокращение диапазона поиска для Min
        i1 = i1 + 1
    Wend
    SortStr List, Compare, i1 + 1, Max
2
End Sub

Option Explicit
'в VB6 разкомментировать эти строки:
'Public Enum LongPtr
'[_]
'End Enum
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
 
Private Type pVariant
    cur As Currency
    Ptr As LongPtr
    lp0 As LongPtr
End Type
Private Type tpDicItemPtr
    pNext As LongPtr
    pKey As pVariant
    pItem As pVariant
End Type
 
#If Win64 Then
    Private Const ptrSz = 8
    Private Const dict1PtrOffset = 48
#Else
    Private Const ptrSz = 4
    Private Const dict1PtrOffset = 28
#End If
 
Sub ПримерИспользования()
    Dim dict As New Dictionary, pSA As LongPtr
    Dim pKeys() As LongPtr, Keys() As String, Ptr0 As LongPtr
    
    dict.Add "key1", "item1"
    dict.Add "key2", "item2"
    dict.Add "key3", "item3"
    
    DictPtrStrKeys dict, pKeys
    
    'CopyMemory ByVal VarPtr(Ptr0) + ptrSz, ByVal VarPtr(Ptr0) + ptrSz * 2, ptrSz 'если не нужен Join
    CopyMemory pSA, ByVal VarPtr(Ptr0) + ptrSz * 2, ptrSz
    CopyMemory ByVal VarPtr(Ptr0) + ptrSz, pSA, ptrSz
    CopyMemory ByVal pSA + &H2, 384, &H2          'без этой строки не работает Join
    
    MsgBox Join$(Keys(), vbCr)
    
    CopyMemory ByVal pSA + &H2, 128, &H2          'без этой строки не освобождаются указатели в массиве
    CopyMemory ByVal VarPtr(Ptr0) + ptrSz, Ptr0, ptrSz
End Sub
 
Private Sub DictPtrStrKeys(Dic As Dictionary, pKeys() As LongPtr)
    Dim DicItem As tpDicItemPtr
    DictPtrStrKeys_ Dic, pKeys, DicItem
End Sub
Private Sub DictPtrStrKeys_(Dic As Dictionary, pKeys() As LongPtr, DicItem As tpDicItemPtr, _
                    Optional Ptr As LongPtr, Optional pPtr As LongPtr, Optional ByVal Ptr0 As LongPtr)
    Dim i As Long, Cnt As Long, pTmp As LongPtr
    
    Cnt = Dic.Count
    If Cnt = 0 Then Exit Sub
    Ptr0 = VarPtr(Ptr0)
    CopyMemory ByVal Ptr0 - ptrSz, Ptr0 - ptrSz * 2, ptrSz
    pPtr = ObjPtr(Dic) + dict1PtrOffset: pTmp = Ptr
    pPtr = Ptr0 - ptrSz * 3: Ptr = pTmp + ptrSz
    ReDim pKeys(Cnt - 1)
    For i = 0 To Cnt - 1
        pKeys(i) = DicItem.pKey.Ptr
        Ptr = DicItem.pNext + ptrSz
    Next
End Sub

Option Explicit
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function VarBstrCmp Lib "oleaut32" (ByVal bstrLeft As LongPtr, ByVal bstrRight As LongPtr, ByVal lcid As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Sub VariantCopy Lib "oleaut32.dll" (pvargDest As Any, pvargSrc As Any)
 
Private Type tpLong
    l As Long
End Type
Private Type tpCurrency
    c As Currency
End Type
#If Win64 Then
    Private Const ptrSz = 8
    Private Const varSz = 24
    Private Const dictPtr1Offset = 48
    Private Const dictpHTblOffset = 64
    Private Const dictDivOffset = 72
    Private Const dictlcidOffset = 80
    Private Const dictSKeyOffset = 24
    Private Const dictItemOffset = 40
    Private Const dictNxtpHItem = 72
#Else
    Private Const ptrSz = 4
    Private Const varSz = 16
    Private Const dictPtr1Offset = 28
    Private Const dictpHTblOffset = 36
    Private Const dictDivOffset = 40
    Private Const dictlcidOffset = 48
    Private Const dictSKeyOffset = 16
    Private Const dictItemOffset = 24
    Private Const dictNxtpHItem = 40
#End If
 
Sub Пример()
    Dim dict As New Dictionary
    
    dict.Add "key1", "item1"
    dict.Add "key2", "item2"
    dict.Add "key3", "item3"
    
    Debug.Print GetItemVBA(dict, "key2")
End Sub
' Получить элемент по ключу. Реплика функции The trick-а https://www.cyberforum.ru/visual-basic/thread1146688.html#post6040814
Private Function GetItemVBA(Dic As Dictionary, Key As String) As Variant
    Dim Hash As Long, pHTbl As LongPtr, pHItem As LongPtr, lcid As Long, iKey As LongPtr, cmp As Long    
    CopyMemory lcid, ByVal ObjPtr(Dic) + dictlcidOffset, ptrSz      ' Получаем lcid
    Hash = HashValVBA(Dic, Key)                                     ' Вычисляем хэш
    CopyMemory pHTbl, ByVal ObjPtr(Dic) + dictpHTblOffset, ptrSz    ' Получаем указатель на хэш-таблицу
    CopyMemory pHItem, ByVal pHTbl + Hash * ptrSz, ptrSz            ' Получаем указатель элемента в хэш-таблице
    Do While pHItem                                                 ' Если есть такой элемент
        CopyMemory iKey, ByVal pHItem + dictSKeyOffset, ptrSz       ' Сравниваем значение ключа в таблице с заданым ключем
        Select Case VarBstrCmp(StrPtr(Key), iKey, lcid, Dic.CompareMode)
        Case 1: VariantCopy GetItemVBA, ByVal pHItem + dictItemOffset: Exit Function
        Case Else
            CopyMemory pHItem, ByVal pHItem + dictNxtpHItem, ptrSz  ' Получаем указатель на следующую запись в таблице
        End Select
    Loop
End Function
 
Private Function HashValVBA(Dic As Dictionary, ByVal s As String) As Long
    Dim i As Long, ch As Currency, Div As Long
    Dim res As tpLong, cres As tpCurrency
    If Dic.CompareMode = TextCompare Then LSet s = StrConv(s, vbLowerCase)
    ' Извращения с Currency, т.к. в VB нет UINT32 и циклической арифметики
    For i = 1 To Len(s)                                             
        ch = AscW(Mid$(s, i, 1)) / 10000
        cres.c = CCur(res.l) / 10000 * 17 + ch
        LSet res = cres
    Next
    cres.c = 0: LSet cres = res 
    ch = cres.c * 10000
    CopyMemory Div, ByVal ObjPtr(Dic) + dictDivOffset, 4 ' Константа
    HashValVBA = (ch - (Int(ch / Div) * Div))
End Function

Sub PRDX_SortRecur_WithInd(aV(), aI() As Long, LBnd&, UBnd&)
Dim i&, j&, n&, x, y
 
i = LBnd: j = UBnd: x = aV((LBnd + UBnd) \ 2)
 
Do
    While aV(i) < x: i = i + 1: Wend
    While x < aV(j): j = j - 1: Wend
    If i <= j Then
        y = aV(i): aV(i) = aV(j): aV(j) = y
        n = aI(i): aI(i) = aI(j): aI(j) = n
        i = i + 1: j = j - 1
    End If
Loop Until i > j
 
If LBnd < j Then PRDX_SortRecur_WithInd aV, aI, LBnd, j
If i < UBnd Then PRDX_SortRecur_WithInd aV, aI, i, UBnd
End Sub

Sub PRDX_SortRecur_a1D(a1D(), LBnd&, UBnd&)
Dim i&, j&, x, y
 
i = LBnd: j = UBnd: x = a1D((LBnd + UBnd) \ 2)
 
Do
    While a1D(i) < x: i = i + 1: Wend
    While x < a1D(j): j = j - 1: Wend
    If i <= j Then y = a1D(i): a1D(i) = a1D(j): a1D(j) = y: i = i + 1: j = j - 1
Loop Until i > j
 
If LBnd < j Then PRDX_SortRecur_a1D a1D, LBnd, j
If i < UBnd Then PRDX_SortRecur_a1D a1D, i, UBnd
End Sub