Как получить название ключа в коллекции

Option Explicit
 
Private CL As Collection
Function Keys()
'Вот тут я остановился
'    Dim f&, v, v1
'    ReDim v(CL.Count - 1)
'    For Each v1 In CL
'        v(f) = CL(f + 1)
'        f = f + 1
'    Next
End Function
 
Public Sub Add(Key$, Item)
    CL.Add Item, Key
End Sub
 
Function Exists(Key) As Boolean
    On Error Resume Next
    Call CL.Item(Key)
    If Err.Number Then Else Exists = True
End Function
 
Function Items() As Variant()
    Dim f&, v, v1
    ReDim v(CL.Count - 1)
    For Each v1 In CL
        v(f) = v1
        f = f + 1
    Next
End Function
 
Private Sub Class_Initialize()
    Set CL = New Collection
End Sub
 
Private Sub Class_Terminate()
    Set CL = Nothing
End Sub

Option Explicit
 
Private Sub Form_Activate()
    Dim d As New DIC, v, v1, d1
    Cls
    Set d1 = CreateObject("Scripting.Dictionary"): d1.CompareMode = 1
    d.Add "Ключ 1", "Пример первой записи"
    d.Add "Ключ 2", "Пример второй записи"
    d1.Add "Ключ", "Пример для сравнения"
    '------------------
    Print d("КлЮч 1"), "DIC"
    Print d("кЛюч 2"), "DIC"
    Print d1("КлюЧ"), "Scripting.Dictionary"
    Print "'---------------------------------"
    v = d.Items  'DIC
    v1 = d1.Items 'Scripting.Dictionary
    '---------------------------------
End Sub

Option Explicit
'
'   Класс Dictionary (© FelixMacintosh)
'
Private c1 As Collection, c2 As Collection
 
Public Property Get Item(ByVal Key As String) As Variant
    Item = c1(Key)
End Property
 
Public Function Keys()
    Dim f&, v
    ReDim v(c1.Count - 1)
    For f = 0 To c1.Count - 1
        v(f) = c2.Item(f + 1)
    Next
    Keys = v
End Function
 
Public Sub Add(Key$, Item)
    c1.Add Item, Key
    c2.Add Key, CStr(c2.Count)
End Sub
 
Function Exists(Key$) As Boolean
    On Error Resume Next
    Call c1.Item(Key)
    If Err.Number Then Else Exists = True
End Function
 
Function Items()
    Dim f&, v
    ReDim v(c1.Count - 1)
    For f = 0 To c1.Count - 1
        v(f) = c1.Item(f + 1)
    Next
    Items = v
End Function
 
Private Sub Class_Initialize()
    Set c1 = New Collection
    Set c2 = New Collection
End Sub
 
Private Sub Class_Terminate()
    Set c1 = Nothing
    Set c2 = Nothing
End Sub

Option Explicit
 
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
 
Private Sub Form_Load()
    Dim Col As Collection, i As Long
    
    Set Col = New Collection
    
    Col.Add "ssss", "item1"
    Col.Add "ssss", "item2"
    Col.Add "ssss", "item3"
    Col.Add "ssss", "item4"
    Col.Add "ssss", "item5"
    
    For i = 1 To Col.Count
        Debug.Print ColKey(i, Col)
    Next
End Sub
Private Function ColKey(ByVal Index As Long, Col As Collection) As String
    Dim lpSTR As Long, Ptr As Long, Key As String
    If Col Is Nothing Then Exit Function
    Select Case Index
    Case Is < 1, Is > Col.Count: Exit Function
    Case Else
        Ptr = ObjPtr(Col)
        Do While Index
            GetMem4 ByVal Ptr + 24, Ptr
            Index = Index - 1
        Loop
    End Select
    lpSTR = StrPtr(Key)
    GetMem4 ByVal Ptr + 16, ByVal VarPtr(Key)
    ColKey = Key
    GetMem4 lpSTR, ByVal VarPtr(Key)
End Function

Private Function ColItem(ByVal Index As Long, Col As Collection) As Variant
    Dim Ptr As Long, Key As Variant
    If Col Is Nothing Then Exit Function
    Select Case Index
    Case Is < 1, Is > Col.Count: Exit Function
    Case Else
        Ptr = ObjPtr(Col)
        Do While Index
            GetMem4 ByVal Ptr + 24, Ptr
            Index = Index - 1
        Loop
    End Select
    GetMem8 ByVal Ptr, ByVal VarPtr(Key)             ' Îäíó ïîëîâèíó êîïèðóåì
    GetMem8 ByVal Ptr + 8, ByVal VarPtr(Key) + 8     ' Âòîðóþ ïîëîâèíó êîïèðóåì
    ColItem = Key
End Function

Private Function ColItem(Key As String, Col As Collection) As Variant
    Dim lpStr As Long, Ptr1 As Long, Ptr2 As Long, sKey As String
 
    GetMem4 ByVal ObjPtr(Col) + 36, Ptr1
    GetMem4 ByVal ObjPtr(Col) + 40, Ptr2
 
    Do Until Ptr1 = Ptr2
        GetMem4 ByVal Ptr1 + 16, lpStr
        Select Case VarBstrCmp(ByVal StrPtr(Key), ByVal lpStr, 1, &H30001)
        Case 0: GetMem4 ByVal Ptr1 + 40, Ptr1
        Case 1
            Ptr2 = VarPtr(ColItem)
            GetMem8 ByVal Ptr1, ByVal Ptr2
            GetMem8 ByVal Ptr1 + 8, ByVal Ptr2 + 8
            Exit Function
        Case Else: GetMem4 ByVal Ptr1 + 36, Ptr1
        End Select
    Loop
    
    MsgBox "Element not found"
End Function

ub Main()
Dim x
With CreateObject("scripting.dictionary")
  .Add "key1", "val1"
  Debug.Print TypeName(.Item("key2")) 'создание элемента при чтении с несуществующим ключем
  .Item("key3") = 4                   'создание элемента при записи с несуществующим ключем
  Debug.Print .Count
  For Each x In .Keys
    Debug.Print x, .Item(x)
  Next
  .Item("key2") = "val2"              'изменение значения существующей записи
  .Key("key1") = "newKey"             'изменение ключа существующей записи
  For Each x In .Keys
    Debug.Print x, .Item(x)
  Next
  .RemoveAll                          'есть в словаре, нет в коллекции
  Debug.Print .Count
  Debug.Print .HashVal("myString")    'скрытое свойство для внутреннего использования,
                                      'практичеcкого значения, видимо, не имеет
  Debug.Print .Count
End With
End Sub

Public Sub RemoveAll()
    Class_Terminate
    Class_Initialize
End Sub

Option Explicit
 
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
 
Private Sub Form_Load()
    Dim Z As Dictionary, q1 As Long, q2 As Long
    
    Set Z = New Dictionary
    
    q1 = Z.HashVal("Verify string")
    q2 = HashVal("Verify string")
End Sub
 
Private Function HashVal(S As String) As Long
    Dim i As Long, ch As Currency, res As Long, cres As Currency
    
    ' Извращения с 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
    HashVal = (ch - (Int(ch / 1201) * 1201))
End Function

Public Enum dicCompareMethod
  dicTextCompare = vbTextCompare  'единственный вариант, предлагаемый в выпадающем списке
End Enum
 
Private bCompModeSet As Boolean 'флаг "режим сравнения установлен"
 
'...
 
Public Property Get CompareMode() As dicCompareMethod
  CompareMode = dicTextCompare
End Property
 
Public Property Let CompareMode(x As dicCompareMethod)
  If x <> dicTextCompare Then Err.Raise 28002, , "This collection supports only TextCompare mode"
  If c1.Count Then Err.Raise 28003, , "Can't change CompareMode while collection is not empty"
  bCompModeSet = True
End Property
 
'...
 
Public Sub Add(Key$, Item)
  If bCompModeSet Then      'не позволяем добавлять элементы, пока режим сравнения не установлен
    c1.Add Item, Key
'...
  Else: Err.Raise 28001, , "CompareMode is not set"
  End If
End Sub