[VBA] Collectionオブジェクトのキーを配列で返す関数

0.README.md

[VBA] Collectionオブジェクトのキーを配列で返す関数

VBAのCollectionオブジェクトでキー一覧を取得する方法が用意されていないので、そのような関数を試作。
※といっても参考にした処理をちょっといじって32/64ビット両対応にしただけともいう…

Function GetCollectionKeys(ByVal TargetCollection As Collection) As Variant()

引数で指定したCollectionオブジェクトに設定されているキー一覧を0オリジンの配列で返す。

……考えてみればCollectionの場合はKeyなしでItemを追加する場合もあるので、使い所は限られるかも……？

参考

• VBA collection: list of keys - Stack Overflow
• [VB6/VBA] Collection keys-VBForums

Mod_GetCollectionKeys.vba

Option Explicit

' ■ Collectionオブジェクトのキーを配列で取得
' Function GetCollectionKeys(ByVal TargetCollection As Collection) As Variant()
' ※戻り値は0オリジンの配列
' ※キー(Key:String)が未設定の要素(Item)については、代わりに要素のIndex(Long)を返す

' 【参考】
'   - [VBA collection: list of keys - Stack Overflow](https://stackoverflow.com/questions/5702362/vba-collection-list-of-keys/50063928#50063928)
'   - [[VB6/VBA] Collection keys-VBForums](https://www.vbforums.com/showthread.php?871471-VB6-VBA-Collection-keys)

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)

Private Type VbCollectionHeader
    pInterface1 As LongPtr
    pInterface2 As LongPtr
    pInterface3 As LongPtr
    lRefCounter As Long
    Count As Long
    pvUnk1 As LongPtr
    pFirstIndexedItem As LongPtr
    pLastIndexedItem As LongPtr
    pvUnk4 As LongPtr
    pRootTreeItem As LongPtr
    pEndTreePtr As LongPtr
    pvUnk5 As LongPtr
End Type

Private Type VbCollectionItem
    Data As Variant
    KeyPtr As LongPtr
    pPrevIndexedItem As LongPtr
    pNextIndexedItem As LongPtr
    pParentItem As LongPtr
    pRightBranch As LongPtr
    pLeftBranch As LongPtr
    bFlag As Boolean
End Type

Private Type VbCollectionOffsetInfo
    IsReady As Boolean
    Header_Count As LongPtr
    Header_pFirstIndexedItem As LongPtr
    Item_KeyPtr As LongPtr
    Item_pNextIndexedItem As LongPtr
End Type

Private CollectionOffsetInfo As VbCollectionOffsetInfo

Private Sub InitCollectionOffsetInfo()
    Dim TestHeader As VbCollectionHeader
    Dim TestItem As VbCollectionItem
    Dim TestHeaderPtr As LongPtr: TestHeaderPtr = VarPtr(TestHeader)
    Dim TestItemPtr As LongPtr: TestItemPtr = VarPtr(TestItem)
    CollectionOffsetInfo.Header_Count = VarPtr(TestHeader.Count) - TestHeaderPtr
    CollectionOffsetInfo.Header_pFirstIndexedItem = VarPtr(TestHeader.pFirstIndexedItem) - TestHeaderPtr
    CollectionOffsetInfo.Item_KeyPtr = VarPtr(TestItem.KeyPtr) - TestItemPtr
    CollectionOffsetInfo.Item_pNextIndexedItem = VarPtr(TestItem.pNextIndexedItem) - TestItemPtr
    CollectionOffsetInfo.IsReady = True
End Sub

Private Function GetString(Address As LongPtr) As Variant
    Const StrlenByteRatio = 2
'    Debug.Assert Address > 0
    If Address < 1 Then
        GetString = Empty ' ItemにKeyが設定されていない場合
        Exit Function
    End If
    Dim WorkStr As String
    Dim Length As Long: Length = GetLong(Address - Len(Length))
    WorkStr = String((Length + (StrlenByteRatio - 1)) \ StrlenByteRatio, 0)
    Call CopyMemory(StrPtr(WorkStr), Address, Length)
    GetString = WorkStr
End Function

Private Function GetLong(Address As LongPtr) As Long
    Debug.Assert Address > 0
    Call CopyMemory(VarPtr(GetLong), Address, Len(GetLong))
End Function

Private Function GetLongPtr(Address As LongPtr) As LongPtr
    Debug.Assert Address > 0
    Call CopyMemory(VarPtr(GetLongPtr), Address, Len(GetLongPtr))
End Function

Public Function GetCollectionKeys(ByVal TargetCollection As Collection) As Variant()
    If Not CollectionOffsetInfo.IsReady Then Call InitCollectionOffsetInfo
    Dim CollectionPtr As LongPtr: CollectionPtr = ObjPtr(TargetCollection)
    Debug.Assert CollectionPtr > 0
    Dim ItemCount As Long: ItemCount = GetLong(CollectionPtr + CollectionOffsetInfo.Header_Count)
    Debug.Assert ItemCount = TargetCollection.Count
    If ItemCount < 1 Then
        GetCollectionKeys = VBA.Array()
        Exit Function
    End If
    Dim KeyArray() As Variant: ReDim KeyArray(0 To ItemCount - 1)
    Dim ItemIndex As Long
    Dim ItemPtr As LongPtr: ItemPtr = GetLongPtr(CollectionPtr + CollectionOffsetInfo.Header_pFirstIndexedItem)
    Dim KeyPtr As LongPtr
    Dim Key As Variant
    Do While ItemPtr > 0
        KeyPtr = GetLongPtr(ItemPtr + CollectionOffsetInfo.Item_KeyPtr)
        Key = GetString(KeyPtr)
        KeyArray(ItemIndex) = IIf(IsEmpty(Key), ItemIndex + 1, Key)
        ItemIndex = ItemIndex + 1
        ItemPtr = GetLongPtr(ItemPtr + CollectionOffsetInfo.Item_pNextIndexedItem)
    Loop
    GetCollectionKeys = KeyArray
End Function