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

'Сортировка словаря методом вставок -> исходный словарь реконструируется
Sub SpecialSortDict(inDict)
    Dim arrPos: arrPos = inDict.keys                    'Инициализация массива позиций ключей словаря
    Dim arrTemp: arrTemp = inDict.Items                 'Виртуализация значений словаря
 
    Dim i, j, xItem
    For i = 1 To UBound(arrTemp)                        'Сортировка методом вставок
        For j = i To 1 Step -1
            If arrTemp(j) < arrTemp(j - 1) Then
                xItem = arrTemp(j)                      'Обмен значений
                arrTemp(j) = arrTemp(j - 1)
                arrTemp(j - 1) = xItem
                xItem = arrPos(j)                       'Обмен ключей
                arrPos(j) = arrPos(j - 1)
                arrPos(j - 1) = xItem
            Else
                Exit For
            End If
        Next
    Next
 
    Dim virtDict: Set virtDict = CreateObject("Scripting.Dictionary")
    For i = 0 To UBound(arrPos)                         'Расставляем значения в виртуальный словарь согласно массива ключей
        virtDict.Add arrPos(i), inDict(arrPos(i))
    Next
 
    Set inDict = virtDict
End Sub

Option Explicit
 
Sub main()
    Dim oScr: Set oScr = CreateObject("Scripting.Dictionary")
    
    oScr.Add "c", 8
    oScr.Add "aa", 1
    oScr.Add "bb", 3
    oScr.Add "a", 2
    oScr.Add "i", 4
    
    SpecialSortDict oScr
    
    Dim key
    For Each key In oScr.keys
        Debug.Print key & " - " & oScr(key)
    Next
    
End Sub

flags = [Текстовые элементы] Or [По убыванию] Or  [Игнорировать регистр]

Option Explicit
 
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function VarBstrCmp Lib "oleaut32" (ByVal bstrLeft As Long, ByVal bstrRight As Long, ByVal lcid As Long, ByVal dwFlags As Long) As Long
Private Declare Sub VariantCopy Lib "oleaut32.dll" (pvargDest As Any, pvargSrc As Any)
 
Private Sub Form_Load()
    Dim Z As Scripting.Dictionary, p As String, i As Long
    
    Set Z = New Dictionary
    
    Z.CompareMode = TextCompare
 
    For i = 0 To 9999
        Z.Add "Key" & CStr(i), "Item" & CStr(i)
    Next
    
    'p = Z.Item("Key2")
    
    p = GetItem(Z, "Key788")
    
    MsgBox p
    
End Sub
 
' Получить элемент по ключу
Private Function GetItem(Dic As Dictionary, Key As String) As Variant
    Dim Hash As Long, pHTbl As Long, pHItem As Long, lcid As Long, cmp As Long, iKey As Long
    ' Получаем lcid
    GetMem4 ByVal ObjPtr(Dic) + &H30, lcid
    ' Вычисляем хэш
    Hash = HashVal(Dic, Key)
    ' Получаем указатель на хэш-таблицу
    GetMem4 ByVal ObjPtr(Dic) + &H24, pHTbl
    ' Получаем указатель элемента в хэш-таблице
    GetMem4 ByVal pHTbl + Hash * 4, pHItem
    ' Если есть такой элемент
    Do While pHItem
        ' Сравниваем значение ключа в таблице с заданым ключем
        GetMem4 ByVal pHItem + 16, iKey
        Select Case VarBstrCmp(StrPtr(Key), iKey, lcid, Dic.CompareMode)
        Case 1: VariantCopy GetItem, ByVal pHItem + &H18: Exit Function
        Case Else: GetMem4 ByVal pHItem + &H28, pHItem ' Получаем указатель на следующую запись в таблице
        End Select
    Loop
    ' Нет такого элемента
End Function
 
Private Function HashVal(Dic As Dictionary, ByVal S As String) As Long
    Dim i As Long, ch As Currency, res As Long, cres As Currency, Div As Long
    If Dic.CompareMode = TextCompare Then S = StrConv(S, vbLowerCase)
    ' Извращения с Currency, т.к. в VB нет UINT32 и циклической арифметики
    For i = 0 To Len(S) - 1
        ch = AscW(Mid$(S, i + 1, 1)) / 10000
        cres = CCur(res) / 10000 * 17 + ch
        GetMem4 cres, res
    Next
    cres = 0: GetMem4 res, cres
    ch = cres * 10000
    GetMem4 ByVal ObjPtr(Dic) + &H28, Div   ' Константа
    HashVal = (ch - (Int(ch / Div) * Div))
End Function

' ObjPtr+&H18 (Dic.Count)
' Получить список элементов
Private Function Items(Dic As Dictionary) As Variant
    Dim pItm As Long, loc() As Variant, i As Long
    
    ReDim loc(Dic.Count - 1)
    ' Указатель на первый элемент списка
    GetMem4 ByVal ObjPtr(Dic) + &H1C, pItm
    ' Проход по элементам списка
    Do
        VariantCopy loc(i), ByVal pItm + &H18
        ' Следующий элемент
        GetMem4 ByVal pItm + 4, pItm
        i = i + 1
    Loop While pItm
    
    Items = loc
End Function

' Получить элемент по индексу
Private Function GetByIndex(Dic As Dictionary, ByVal Index As Long) As Variant
    Dim pItm As Long
    
    If Dic.Count = 0 Then Exit Function
    
    ' Указатель на первый элемент списка
    GetMem4 ByVal ObjPtr(Dic) + &H1C, pItm
    ' Проход по элементам списка
    Do While CBool(Index) And pItm
        ' Следующий элемент
        GetMem4 ByVal pItm + 4, pItm
        Index = Index - 1
    Loop
 
    VariantCopy GetByIndex, ByVal pItm + &H18
End Function

Private Type DicItem
    Key As Variant
    Item As Variant
End Type
Private Sub GetPair(Dic As Dictionary, Out() As DicItem)
    Dim pItm As Long, i As Long
    
    If Dic.Count = 0 Then Exit Sub
    
    ReDim Out(Dic.Count - 1)
    ' Указатель на первый элемент списка
    GetMem4 ByVal ObjPtr(Dic) + &H1C, pItm
    ' Проход по элементам списка
    Do
        VariantCopy Out(i).Item, ByVal pItm + &H8
        VariantCopy Out(i).Key, ByVal pItm + &H18
        ' Следующий элемент
        GetMem4 ByVal pItm + 4, pItm
        i = i + 1
    Loop While pItm
End Sub

' Сортировка методом вставок на месте (сортируются значения)
Private Sub Sort(Dic As Dictionary)
    Dim lh As Long, e As Long, se As Long, bs As Long, be As Long, s As Long, lcid As Long
    GetMem4 ByVal ObjPtr(Dic) + &H30, lcid
    ' Указатель на первый элемент списка
    GetMem4 ByVal ObjPtr(Dic) + &H1C, lh
    be = lh
    GetMem4 ByVal lh + 4, e
    ' Проход
    Do While e
        s = 0: se = lh: bs = 0
        Do Until se = e
            If VarCmp(e + &H18, se + &H18, lcid, 0) < 2 Then
                GetMem4 ByVal e + &H4, ByVal be + &H4
                GetMem4 se, ByVal e + &H4
                If bs Then
                    GetMem4 e, ByVal bs + &H4
                Else: lh = e
                End If
                GetMem4 ByVal be + &H4, e
                bs = 0: s = 1
                Exit Do
            Else
                bs = se
                GetMem4 ByVal se + &H4, se
            End If
        Loop
        If s = 0 Then
            be = e
            GetMem4 ByVal e + &H4, e
        End If
    Loop
    GetMem4 lh, ByVal ObjPtr(Dic) + &H1C
End Sub

Private Type DictionaryItem
    pInterface As Long      '0
    pNext As Long           '4
    Key As Variant          '8
    Item As Variant         '18
    PointerToHash As Long   '28
    Reserved As Long        '2C
End Type

Option Explicit
'
'Сортировка словаря !
'© FelixMacintosh (Антихакер32™)
'
Const Elemens = 100
Dim Dic1 As Dictionary
Dim Dic2 As Dictionary
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
    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
    Form1.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 Elemens
        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