VBA collection: list of keys

After I add some values to the VBA collection, is there any way to retain the list of all keys?

For example

Dim coll as new  Collection
Dim str1, str2, str3
str1="first string"
str2="second string"
str3="third string"
coll.add str1, "first key"
coll.add str2, "second key"
coll.add str3, "third key"

I know how to retain the list开发者_运维问答 of strings:

first string
second string
third string

Once again: is there any way to retain the keys?

first key
second key
third key

Note: I'm using VBA through AutoCAD 2007

If you intend to use the default VB6 Collection, then the easiest you can do is:

col1.add array("first key", "first string"), "first key"
col1.add array("second key", "second string"), "second key"
col1.add array("third key", "third string"), "third key"

Then you can list all values:

Dim i As Variant

For Each i In col1
  Debug.Print i(1)
Next

Or all keys:

Dim i As Variant

For Each i In col1
  Debug.Print i(0)
Next

I don't thinks that possible with a vanilla collection without storing the key values in an independent array.

The easiest alternative to do this is to add a reference to the Microsoft Scripting Runtime & use a more capable Dictionary instead:

Dim dict As Dictionary
Set dict = New Dictionary

dict.Add "key1", "value1"
dict.Add "key2", "value2"

Dim key As Variant
For Each key In dict.Keys
    Debug.Print "Key: " & key, "Value: " & dict.Item(key)
Next

You can create a small class to hold the key and value, and then store objects of that class in the collection.

Class KeyValue:

Public key As String
Public value As String
Public Sub Init(k As String, v As String)
    key = k
    value = v
End Sub

Then to use it:

Public Sub Test()
    Dim col As Collection, kv As KeyValue
    Set col = New Collection
    Store col, "first key", "first string"
    Store col, "second key", "second string"
    Store col, "third key", "third string"
    For Each kv In col
        Debug.Print kv.key, kv.value
    Next kv
End Sub

Private Sub Store(col As Collection, k As String, v As String)
    If (Contains(col, k)) Then
        Set kv = col(k)
        kv.value = v
    Else
        Set kv = New KeyValue
        kv.Init k, v
        col.Add kv, k
    End If
End Sub

Private Function Contains(col As Collection, key As String) As Boolean
    On Error GoTo NotFound
    Dim itm As Object
    Set itm = col(key)
    Contains = True
MyExit:
    Exit Function
NotFound:
    Contains = False
    Resume MyExit
End Function

This is of course similar to the Dictionary suggestion, except without any external dependencies. The class can be made more complex as needed if you want to store more information.

You can snoop around in your memory using RTLMoveMemory and retrieve the desired information directly from there:

32-Bit:

Option Explicit

'Provide direct memory access:
Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As Long, _
    ByVal Source As Long, _
    ByVal Length As Long)


Function CollectionKeys(oColl As Collection) As String()

    'Declare Pointer- / Memory-Address-Variables
    Dim CollPtr As Long
    Dim KeyPtr As Long
    Dim ItemPtr As Long

    'Get MemoryAddress of Collection Object
    CollPtr = VBA.ObjPtr(oColl)

    'Peek ElementCount
    Dim ElementCount As Long
    ElementCount = PeekLong(CollPtr + 16)

        'Verify ElementCount
        If ElementCount <> oColl.Count Then
            'Something's wrong!
            Stop
        End If

    'Declare Simple Counter
    Dim index As Long

    'Declare Temporary Array to hold our keys
    Dim Temp() As String
    ReDim Temp(ElementCount)

    'Get MemoryAddress of first CollectionItem
    ItemPtr = PeekLong(CollPtr + 24)

    'Loop through all CollectionItems in Chain
    While Not ItemPtr = 0 And index < ElementCount

        'increment Index
        index = index + 1

        'Get MemoryAddress of Element-Key
        KeyPtr = PeekLong(ItemPtr + 16)

        'Peek Key and add to temporary array (if present)
        If KeyPtr <> 0 Then
           Temp(index) = PeekBSTR(KeyPtr)
        End If

        'Get MemoryAddress of next Element in Chain
        ItemPtr = PeekLong(ItemPtr + 24)

    Wend

    'Assign temporary array as Return-Value
    CollectionKeys = Temp

End Function


'Peek Long from given MemoryAddress
Public Function PeekLong(Address As Long) As Long

  If Address = 0 Then Stop
  Call MemCopy(VBA.VarPtr(PeekLong), Address, 4&)

End Function

'Peek String from given MemoryAddress
Public Function PeekBSTR(Address As Long) As String

    Dim Length As Long

    If Address = 0 Then Stop
    Length = PeekLong(Address - 4)

    PeekBSTR = Space(Length \ 2)
    Call MemCopy(VBA.StrPtr(PeekBSTR), Address, Length)

End Function

64-Bit:

Option Explicit

'Provide direct memory access:
Public Declare PtrSafe Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" ( _
     ByVal Destination As LongPtr, _
     ByVal Source As LongPtr, _
     ByVal Length As LongPtr)



Function CollectionKeys(oColl As Collection) As String()

    'Declare Pointer- / Memory-Address-Variables
    Dim CollPtr As LongPtr
    Dim KeyPtr As LongPtr
    Dim ItemPtr As LongPtr

    'Get MemoryAddress of Collection Object
    CollPtr = VBA.ObjPtr(oColl)

    'Peek ElementCount
    Dim ElementCount As Long
    ElementCount = PeekLong(CollPtr + 28)

        'Verify ElementCount
        If ElementCount <> oColl.Count Then
            'Something's wrong!
            Stop
        End If

    'Declare Simple Counter
    Dim index As Long

    'Declare Temporary Array to hold our keys
    Dim Temp() As String
    ReDim Temp(ElementCount)

    'Get MemoryAddress of first CollectionItem
    ItemPtr = PeekLongLong(CollPtr + 40)

    'Loop through all CollectionItems in Chain
    While Not ItemPtr = 0 And index < ElementCount

        'increment Index
        index = index + 1

        'Get MemoryAddress of Element-Key
        KeyPtr = PeekLongLong(ItemPtr + 24)

        'Peek Key and add to temporary array (if present)
        If KeyPtr <> 0 Then
           Temp(index) = PeekBSTR(KeyPtr)
        End If

        'Get MemoryAddress of next Element in Chain
        ItemPtr = PeekLongLong(ItemPtr + 40)

    Wend

    'Assign temporary array as Return-Value
    CollectionKeys = Temp

End Function


'Peek Long from given Memory-Address
Public Function PeekLong(Address As LongPtr) As Long

  If Address = 0 Then Stop
  Call MemCopy(VBA.VarPtr(PeekLong), Address, 4^)

End Function

'Peek LongLong from given Memory Address
Public Function PeekLongLong(Address As LongPtr) As LongLong

  If Address = 0 Then Stop
  Call MemCopy(VBA.VarPtr(PeekLongLong), Address, 8^)

End Function

'Peek String from given MemoryAddress
Public Function PeekBSTR(Address As LongPtr) As String

    Dim Length As Long

    If Address = 0 Then Stop
    Length = PeekLong(Address - 4)

    PeekBSTR = Space(Length \ 2)
    Call MemCopy(VBA.StrPtr(PeekBSTR), Address, CLngLng(Length))

End Function

An alternative solution is to store the keys in a separate Collection:

'Initialise these somewhere.
Dim Keys As Collection, Values As Collection

'Add types for K and V as necessary.
Sub Add(K, V) 
Keys.Add K
Values.Add V, K
End Sub

You can maintain a separate sort order for the keys and the values, which can be useful sometimes.

You can easily iterate you collection. The example below is for the special Access TempVars collection, but works with any regular collection.

Dim tv As Long
For tv = 0 To TempVars.Count - 1
    Debug.Print TempVars(tv).Name, TempVars(tv).Value
Next tv