愚者の経験

「また今度」はほとんどこない

CollectionのKeyやIndexを取得

IndexからKeyを取得って出来るんですね。
メモリ操作を伴うので邪道というか禁じ手かもしれませんが。

参考URL:http://www.vbforums.com/showthread.php?570762-Get-Index-Key-in-Collection-from-other

こうゆうのってどこで調べるんでしょうかね?

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  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

ちょっと危険な気もしますが、コレクションをセットで用意せずともいいメリットがあります。
いちいちこんな感じで用意するのはめんどくさいです。Removeとか同期取る必要ありますし。

    Values Add Value, Key
    Keys.Add Key, Key

また若干処理速度が速そうです。簡単に実験してみました。


Private Function ItemIndex1(ByVal key As String, _
                Coll As Collection, _
                Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
 
  'get collection index by key
 
  Dim Ptr   As Long
  Dim sKey  As String
  Dim aKey  As Long
 
    aKey = StrPtr(sKey)                         'save StrPtr
    RtlMoveMemory Ptr, ByVal ObjPtr(Coll) + 24       'first Ptr
    ItemIndex1 = 1                               'walk items upwards from first
    Do
        RtlMoveMemory ByVal VarPtr(sKey), ByVal Ptr + 16
        If StrComp(key, sKey, Compare) = 0 Then 'equal
            Exit Do                             'found
        End If
        ItemIndex1 = ItemIndex1 + 1               'next Index
        RtlMoveMemory Ptr, ByVal Ptr + 24            'next Ptr
    Loop Until Ptr = 0                          'end of chain
    RtlMoveMemory ByVal VarPtr(sKey), aKey           'restore original StrPtr
 
End Function

Private Function ItemIndex2(ByVal key As String, _
                Coll As Collection, _
                Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
  
    Dim sKey As Variant
    
    For Each sKey In Coll
        ItemIndex2 = ItemIndex2 + 1
        If StrComp(key, sKey, Compare) = 0 Then 'equal
            Exit For                             'found
        End If
    Next
End Function

Public Sub test()
    Dim c As Collection
    Dim k As Collection
    Dim i As Long
    
    Dim tm As Single
    
    Set c = New Collection
    Set k = New Collection
    
    For i = 0 To 10000
        c.Add i, CStr(i)
        k.Add CStr(i), CStr(i)
    Next
    
    tm = Timer
    For i = 0 To 1000
        ItemIndex1 10000, c
    Next
    
    Debug.Print Timer - tm
    
    tm = Timer
    For i = 0 To 1000
        ItemIndex2 10000, k
    Next
    
    Debug.Print Timer - tm
End Sub

イミディエイト
test
1.574219
2.679688
1.5625
2.660156
1.558594
2.691406

広告

CollectionのKeyやIndexを取得」への1件のフィードバック

  1. ピンバック:コレクションをいろいろ自作してみる(機能考察編) | 愚者の経験

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中

%d人のブロガーが「いいね」をつけました。