Get Index/Key in Collection from other

[deathfxu]

Option Explicit
 
Private Declare Sub PokeLong Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
 
Private Function ItemKey(ByVal Index As Long, Coll As Collection) As String
 
  'optimized get collection sKey by index
  'Private Declare Sub PokeLong Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
 
  Dim i     As Long
  Dim Ptr   As Long
  Dim sKey  As String
 
    If Coll Is Nothing Then                             'oops!
        Err.Raise 91                                    'No object
      Else 'NOT COLL...
        Select Case Index
          Case Is < 1, Is > Coll.Count                  'oops!
            Err.Raise 9                                 'Index out of range
          Case Is <= Coll.Count / 2                     'walk items upwards from first
            PokeLong Ptr, ByVal ObjPtr(Coll) + 24       'first Ptr
            For i = 2 To Index
                PokeLong Ptr, ByVal Ptr + 24            'next Ptr
            Next i
          Case Else                                     'walk items downwards from last
            PokeLong Ptr, ByVal ObjPtr(Coll) + 28       'last Ptr
            For i = Coll.Count - 1 To Index Step -1
                PokeLong Ptr, ByVal Ptr + 20            'prev Ptr
            Next i
        End Select
        i = StrPtr(sKey)                                'save StrPtr
        PokeLong ByVal VarPtr(sKey), ByVal Ptr + 16     'replace StrPtr by that from collection sKey (which is null if there ain't no sKey)
        ItemKey = sKey                                  'now copy it to function value
        PokeLong ByVal VarPtr(sKey), i                  'and finally restore original StrPtr
    End If
 
End Function
 
Private Function ItemIndex(ByVal Key As String, Coll As Collection, Optional ByVal Compare As VbCompareMethod = vbTextCompare) As Long
 
  'get collection index by key
  'Private Declare Sub PokeLong Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
 
  Dim Ptr   As Long
  Dim sKey  As String
  Dim aKey  As Long
 
    If Coll Is Nothing Then                             'oops!
        Err.Raise 91                                    'No object
      Else 'NOT COLL...
        If Coll.Count Then
            aKey = StrPtr(sKey)                         'save StrPtr
            PokeLong Ptr, ByVal ObjPtr(Coll) + 24       'first Ptr
            ItemIndex = 1                               'walk items upwards from first
            Do
                PokeLong ByVal VarPtr(sKey), ByVal Ptr + 16
                If StrComp(Key, sKey, Compare) = 0 Then 'equal
                    Exit Do                             'found
                End If
                ItemIndex = ItemIndex + 1               'next Index
                PokeLong Ptr, ByVal Ptr + 24            'next Ptr
            Loop Until Ptr = 0                          'end of chain
            PokeLong ByVal VarPtr(sKey), aKey           'restore original StrPtr
        End If
        If Ptr = 0 Then
            ItemIndex = -1                              'key not found
        End If
    End If
 
End Function

[code courtesy of PSC]