View collection key during debug

[GaelicFatboy]

Hi Everyone,

I have a sub which uses a collection to store twenty or so variables, each of which I give a name as the key. During debugging I can view the collection in the locals window but the valuables are listed by item number only. Is there a way to view the key name for each item as well as the variable?

Cheers

D

 

[MajP]

Use a Dictionary instead of a Collection.

 

[arnelgp]

there is a very good answer to this site:
https://stackoverflow.com/questions/5702362/vba-collection-list-of-keys

example:

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

Private Sub test()
Dim coll As New Collection
Dim vKeys As Variant
Dim i As Integer
coll.Add "a", "11111"
coll.Add "b", "22222"
If coll.Count > 0 Then
    vKeys = CollectionKeys(coll)
    For i = 0 To UBound(vKeys)
        Debug.Print vKeys(i)
    Next
End If
End Sub

you also copy the x64 code if your office is x64.

 

[MajP]

I rolled my own KeyedCollection Class and seems to work real well. Pretty easy to do. If not comfortable with using dictionaries this works and acts like a collection.

Here is the test and use.

Public Sub TestKeyedCollection()
  Dim KC As New KeyedCollection
  KC.Add "John", 30
  KC.Add "Mike", 29
  KC.Add "Karen", 45
  printout KC
  Debug.Print KC.ItemByKey("Mike")
  KC.RemoveByIndex (1)
  printout KC
  KC.RemoveByKey "Karen"
  printout KC
  'KC.Add "Mike", 40  throws expected error
  Dim c As New Collection
  KC.Add "Coll", c
  Dim d As Collection ' works with objects
  Set d = KC.ItemByKey("Coll") 'works with objects
  Debug.Print KC.InList("Mary")
  Debug.Print KC.InList("Mike")
End Sub
Public Sub printout(KC As KeyedCollection)
  Dim i As Integer
  Debug.Print
  For i = 1 To KC.count
    Debug.Print KC.Keys(i) & " " & KC.ItemByIndex(i)
  Next i
end sub

Here is the class must be called KeyedCollection

Option Compare Database
Option Explicit

Private mValues As New Collection
Private mKeys As New Collection
Public Property Get count() As Long
  count = mValues.count
End Property
Public Function Add(ByVal Key As Variant, ByVal Value As Variant) As Variant
  If Not InList(Key) Then
     Me.Values.Add Value, Key
     Me.Keys.Add Key, Key
     If IsObject(Value) Then
       Set Add = Value
     Else
       Add = Value
     End If
  Else
    'this will throw the error could put a message box here
    Me.Keys.Add Key, Key
  End If
End Function

Public Property Get ItemByIndex(index As Variant) As Variant
  index = CLng(index)
  If IsObject(Me.Values.Item(index)) Then
    Set ItemByIndex = mValues.Item(index)
  Else
    ItemByIndex = Me.Values.Item(index)
  End If
End Property
Public Property Get ItemByKey(Key As Variant) As Variant
  Dim i As Integer
  Dim found As Boolean
  i = GetIndexFromKey(Key)
  If IsObject(Me.Values(i)) Then
      Set ItemByKey = Me.Values.Item(i)
   Else
       ItemByKey = Me.Values.Item(i)
   End If
 End Property
Public Sub RemoveByIndex(index As Long)
 Me.Values.Remove index
 Me.Keys.Remove index
End Sub
Public Sub RemoveByKey(Key As Variant)
 Dim index As Long
 If InList(Key) Then
    index = GetIndexFromKey(Key)
    Me.Values.Remove index
    Me.Keys.Remove index
 Else
   Me.Values.Remove -1 ' through error
 End If
End Sub
Public Function Values() As Collection
  'This is a workaround since you cannot overload
      Set Values = mValues
End Function
Public Function Keys() As Collection
  'This is a workaround since you cannot overload
      Set Keys = mKeys
End Function

Public Function InList(Key As Variant) As Boolean
  Dim i As Integer
  For i = 1 To Me.count
    If Me.Keys(i) = Key Then
      InList = True
      Exit Function
    End If
  Next i
End Function
Public Function GetIndexFromKey(Key As Variant) As Long
  Dim i As Integer
  Dim found As Boolean
  For i = 1 To Me.count
     If Me.Keys(i) = Key Then
       found = True
       Exit For
     End If
  Next i
  If found Then
     GetIndexFromKey = i
  Else
    GetIndexFromKey = -1 'to throw error
  End If
End Function

 

[GaelicFatboy]

I had a think about this over night. The easiest solution I could come up with is to make a Class module with two properties, namely VariableValue and VariableName, then make a collection of this class.

Thanks for your help.

D

 

[MajP]

that is not a bad idea. That is how it works in VB.net. There is a KeyValuePair class. And many of the structures can return a key value pair as well. So you could build your KeyValuePair class and make a collection of them. You then could add a function to the KC class and return a key value pair.