カスタムDictionaryクラスを作ろう(13)

VBAクラス・モジュール VBA自作クラス VBA一般

カスタムDictionaryクラスを作ろう(13)

akashi-keirin.hatenablog.com

重大な見落としがありました。

これがほんとの最後の仕上げです。

過去記事

現時点のソースコードです。

現時点のDictionaryモジュール
ソースコードを 
Option Explicit

Public Enum CompareMethod
    BinaryCompare = 0
    TextCompare = 1
    DatabaseCompare = 2
End Enum

Private m_Dictionary As Object

Private Sub Class_Initialize()
    Set m_Dictionary = CreateObject("Scripting.Dictionary")
End Sub

Public Property Get CompareMode() As CompareMethod
    CompareMode = m_Dictionary.CompareMode
End Property

Public Property Let CompareMode(ByVal CompareMode As CompareMethod)
    Const ERR_SOURCE As String = "`CompareMode` property(Let)"
    ' 本家Dictionaryは、要素追加後にCompareModeを設定しようとするとエラーになる
    '   -> ちょっと親切なエラーを吐く
    If m_Dictionary.Count > 0 Then _
        Call RaiseError(ERR_SOURCE, "要素追加後にCompareModeの変更はできない。")
        
    ' そもそもわけのわからない値を渡すことは許さん！
    If CompareMode < 0 Or CompareMode > 2 Then _
        Call RaiseError(ERR_SOURCE, "CompareMethod列挙体以外の値を渡してはいけない。")
        
    ' Access以外でDatabaseCompareを設定することは許さん！
    If (Application.Name = "Microsoft Access") Then GoTo Finally
    If CompareMode = DatabaseCompare Then _
        Call RaiseError(ERR_SOURCE, "Access以外でDatabaseCompareを使ってはいけない。")
    
Finally:
    m_Dictionary.CompareMode = CompareMode
End Property

Public Property Get Count() As Long
    Count = m_Dictionary.Count
End Property

Public Property Get Item(ByVal Key As Variant) As Variant
    If IsObject(m_Dictionary.Item(Key:=Key)) Then
        Set Item = m_Dictionary.Item(Key:=Key)
    Else
        Item = m_Dictionary.Item(Key:=Key)
    End If
End Property

Public Property Let Item( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Item property(Let)"
    ' オブジェクトが渡された
    If IsObject(Item) Then _
        Call RaiseError( _
            a_Source:=ERR_SOURCE, _
            a_Description:="オブジェクトを渡すときは`Set`を使わなければいけない。")
    
    m_Dictionary.Item(Key:=Key) = Item
End Property

Public Property Set Item( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Item property(Set)"
    
    Set m_Dictionary.Item(Key:=Key) = Item
End Property

Public Property Let Key( _
            ByVal Key As Variant, _
            ByVal NewKey As Variant)
    Const ERR_SOURCE As String = "Key property(Let)"
    
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call RaiseError(ERR_SOURCE, "存在しないキーを指定してはいけない。")
    
    If m_Dictionary.Exists(Key:=NewKey) Then _
        Call RaiseError(ERR_SOURCE, "既存のキーに変更することはできない。")
        
    m_Dictionary.Key(Key:=Key) = NewKey
End Property

Public Sub Add( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Add() method(Sub)"
    
    ' 既存のキーにアイテムを設定しようとした
    If m_Dictionary.Exists(Key) Then
        Call RaiseError( _
            a_Source:=ERR_SOURCE, _
            a_Description:="既存のキーにはアイテムを設定できない。")
    End If
    
    Call m_Dictionary.Add( _
        Key:=Key, _
        Item:=Item)
End Sub

Public Function Exists(ByVal Key As Variant) As Boolean
    Exists = m_Dictionary.Exists(Key)
End Function

Public Function Keys() As Variant
    Keys = m_Dictionary.Keys
End Function

Public Function Items() As Variant
    Items = m_Dictionary.Items
End Function

Public Sub Remove(ByVal Key As Variant)
    Const ERR_SOURCE As String = "Remove() method"
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call RaiseError(ERR_SOURCE, "存在しないキーを指定してはいけない。")
    
    Call m_Dictionary.Remove(Key:=Key)
End Sub

Public Sub RemoveAll()
    Call m_Dictionary.RemoveAll
End Sub

Private Sub RaiseError( _
            ByVal a_Source As String, _
            ByVal a_Description As String)
        ' エラーオブジェクトに渡すパラメータを用意
    Dim errNum As Long, errDesc As String, errSrc As String
    errNum = vbObjectError + 1
    errSrc = "Dictionary class: " & a_Source
    errDesc = "( ´,_ゝ`) < ﾌﾟｰｸｽｸｽｗ " & a_Description & "（クソが。）"
    
    ' 例外スロー
    Call Err.Raise( _
        Number:=errNum, _
        Source:=errSrc, _
        Description:=errDesc)
End Sub

For Each ... Nextへの対応

重大な見落としがありました。

そういえば、Scripting.Dictionaryは、変数dicにScripting.Dictionaryのインスタンスが格納されているとして、

Dim k As Variant
For Each k In dic
    ' ...
Next

このようにすることによって、

キーを列挙できるというキテレツな動き

をするのです。

ちょっと意味がわかりませんが、事実です。

「そんなもん、キーを列挙したいんやったら大人しくFor Each k In dict.Keys()って書けや。」と思うのは、私の心が狭いのでしょうか……？

しかたがないので、忠実に実装することにします。

方針

VBA歴10年を超える剛の者である私ですが、

内部にCollectionオブジェクトを置いてNewEnum()メソッドを実装する

という方法しか思いつきません。

つまり、内部ディクショナリのキーをクラスモジュール内部のコレクションにも格納しておく、と言うやり方です。

ただし、内部ディクショナリのキーと、内部コレクションに格納したキーを完全に同期させる、という困難なミッションが伴います。

内部ディクショナリと内部コレクションを同期させる必要があるのは、次のプロパティ、メソッドですね。

  • Add()メソッド
  • Remove()メソッド
  • RemoveAll()メソッド
  • Item（Let/Set）プロパティ
  • Key（Let）プロパティ

……。存在しないキーを指定したItemプロパティへの代入で要素が追加できたり、Keyプロパティでキーを変更できたりする、という変態仕様のせいで、めちゃくちゃややこしくなっています。

では、順に実装していきましょう。

内部コレクションの追加

リスト1-1（宣言セクション）
Private m_KeyCollection As Collection

まず、内部キーコレクションを格納するためのモジュールレベル変数を用意します。

リスト1-2（Class_Initialize()メソッド）
Private Sub Class_Initialize()
    Set m_Dictionary = CreateObject("Scripting.Dictionary")
    Set m_KeyCollection = New Collection
End Sub

貧弱コンストラクタで、内部キーコレクションにインスタンスを格納しておきます。

Add()メソッドの修正

リスト1-3
Public Sub Add( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Add() method(Sub)"
    
    ' 既存のキーにアイテムを設定しようとした
    If m_Dictionary.Exists(Key) Then
        Call RaiseError( _
            a_Source:=ERR_SOURCE, _
            a_Description:="既存のキーにはアイテムを設定できない。")
    End If
    
    Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))
    
    Call m_Dictionary.Add(Key:=Key, Item:=Item)
End Sub

Add()メソッドは、新たに要素を追加するメソッドなので、要素を追加すると同時にキーコレクションにもキーを追加するようにしています。

実は、この実装には問題があります。

ディクショナリのキーにはオブジェクトも指定できてしまうので、ディクショナリにオブジェクトをキーとした要素を追加すると、当然

Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))

ここでエラーになるはずです。

個人的には、ディクショナリのキーをオブジェクトにするような変態的な使い方は禁止してしまいたいのですが、いかがでしょう？

Remove()メソッド

リスト1-4
Public Sub Remove(ByVal Key As Variant)
    Const ERR_SOURCE As String = "Remove() method"
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call RaiseError(ERR_SOURCE, "存在しないキーを指定してはいけない。")
    
    Call m_KeyCollection.Remove(Index:=CStr(Key))
    Call m_Dictionary.Remove(Key:=Key)
End Sub

Remove()は、要素を消すだけなので、同じようにキーコレクションからアイテムを消してやれば良いわけですから、比較的素直な実装で良いでしょう。（これも先ほどのAdd()メソッド同様、イマイチな実装です。）

Item(Let/Set)プロパティ

リスト1-5
Public Property Let Item( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Item property(Let)"
    ' オブジェクトが渡された
    If IsObject(Item) Then _
        Call RaiseError( _
            a_Source:=ERR_SOURCE, _
            a_Description:="オブジェクトを渡すときは`Set`を使わなければいけない。")
            
    ' 既存のキーでない -> キーのコレクションに追加
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))
        
    m_Dictionary.Item(Key:=Key) = Item
End Property

Public Property Set Item( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Item property(Set)"
    
    ' 既存のキーでない -> キーのコレクションに追加
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))
        
    Set m_Dictionary.Item(Key:=Key) = Item
End Property

Itemプロパティは、

dic.Item("<存在しないキー>") = <アイテム>

とか、デフォルトプロパティなので

dic("<存在しないキー>") = <アイテム>

という書き方で新しい要素が追加できてしまう、というよくわからない仕様になっています。

そこで、

If Not m_Dictionary.Exists(Key:=Key) Then

で既存のキーでないキーが指定されたときは、

Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))

このように内部コレクションにキーを格納しています。

Key（Let）プロパティ

コイツがやっかいです。

何せ、既に存在しているキーを書き換える、という意味不明な仕様だからです。

コレクションの場合、要素をピンポイントで指定して書き換える、ということができず、

  • 元のキーを削除
  • 新しいキーを追加

というやり方をすると、元のキーがコレクションの最後の要素でもない限り、内部ディクショナリと内部キーコレクションの順序が食い違ってしまいます。

リスト1-6
Public Property Let Key( _
            ByVal Key As Variant, _
            ByVal NewKey As Variant)
    Const ERR_SOURCE As String = "Key property(Let)"
    
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call RaiseError(ERR_SOURCE, "存在しないキーを指定してはいけない。")
    
    If m_Dictionary.Exists(Key:=NewKey) Then _
        Call RaiseError(ERR_SOURCE, "既存のキーに変更することはできない。")
    
    ' まず内部Dictionaryを更新
    m_Dictionary.Key(Key:=Key) = NewKey
    
    ' キーCollectionを詰め込み直すしかない……。
    Set m_KeyCollection = New Collection
    Dim k As Variant
    For Each k In m_Dictionary.Keys()
        Call m_KeyCollection.Add(Item:=k, Key:=CStr(k))
    Next
End Property

しかたがないので、Keyプロパティを用いてキーを書き換えたときに限り、内部ディクショナリのKeys()メソッドによってキーを列挙させ、内部キーコレクションにイチから詰め込み直すことにしました。

当然、要素数が大量であるときに頻繁に呼び出すとオーバーヘッドがバカにならないとは思います。

とはいえ、そもそも〝ディクショナリのキーを書き換える〟というのはかなり変態的な運用だと思うので、これで納得するしかないでしょう。

もし、他に良いやり方があったら教えてください。

NewEnum()メソッド

For Each ... Nextで列挙できるようにするための最後の仕上げです。

リスト1-7-1
Public Function NewEnum() As IUnknown
    Set NewEnum = m_KeyCollection.[_NewEnum]
End Function

もちろん、これだけではだめで、一旦エクスポートして、テキストエディタで次のように追記しないといけません。

リスト1-7-2
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = m_KeyCollection.[_NewEnum]
End Function

これでインポートし直したらOKです。

動作確認

リスト2
Private Sub DictionaryTest01()
    Dim dic As New Dictionary
    Call dic.Add(Key:="pachinko", Item:="123")
    Call dic.Add(Key:="slot", Item:="123")
    Call dic.Add(Key:="nobuta", Item:="group")
    Dim k As Variant
    For Each k In dic
        Debug.Print k
    Next
    dic.Key("pachinko") = "chinkopa"
    For Each k In dic
        Debug.Print k
    Next
End Sub

要素を3つ追加したあと、一旦For Each ... Nextでキーを列挙してイミディエイトに出力し、その後忌まわしきKeyプロパティでキーを書き換えた後、再びFor Each ... Nextでキーを列挙してイミディエイトに出力するコードです。

バッチリです。

おわりに

オブジェクトをキーにしたときにはまともに動かないし、Cstr()で文字列化できないキーもダメ、"123"と123のようにCStr()の結果が同じになるキーを使うと死ぬ、というポンコツなオブジェクトですが、そのあたりは追々ガードを追加していくということでご容赦ください。

カスタムDictionaryクラスのソースコード
ソースコードを 
Option Explicit

Public Enum CompareMethod
    BinaryCompare = 0
    TextCompare = 1
    DatabaseCompare = 2
End Enum

Private m_Dictionary As Object
Private m_KeyCollection As Collection

Private Sub Class_Initialize()
    Set m_Dictionary = CreateObject("Scripting.Dictionary")
    Set m_KeyCollection = New Collection
End Sub

Public Property Get CompareMode() As CompareMethod
    CompareMode = m_Dictionary.CompareMode
End Property

Public Property Let CompareMode(ByVal CompareMode As CompareMethod)
    Const ERR_SOURCE As String = "`CompareMode` property(Let)"
    ' 本家Dictionaryは、要素追加後にCompareModeを設定しようとするとエラーになる
    '   -> ちょっと親切なエラーを吐く
    If m_Dictionary.Count > 0 Then _
        Call RaiseError(ERR_SOURCE, "要素追加後にCompareModeの変更はできない。")
        
    ' そもそもわけのわからない値を渡すことは許さん！
    If CompareMode < 0 Or CompareMode > 2 Then _
        Call RaiseError(ERR_SOURCE, "CompareMethod列挙体以外の値を渡してはいけない。")
        
    ' Access以外でDatabaseCompareを設定することは許さん！
    If (Application.Name = "Microsoft Access") Then GoTo Finally
    If CompareMode = DatabaseCompare Then _
        Call RaiseError(ERR_SOURCE, "Access以外でDatabaseCompareを使ってはいけない。")
    
Finally:
    m_Dictionary.CompareMode = CompareMode
End Property

Public Property Get Count() As Long
    Count = m_Dictionary.Count
End Property

Public Property Get Item(ByVal Key As Variant) As Variant
    If IsObject(m_Dictionary.Item(Key:=Key)) Then
        Set Item = m_Dictionary.Item(Key:=Key)
    Else
        Item = m_Dictionary.Item(Key:=Key)
    End If
End Property

Public Property Let Item( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Item property(Let)"
    ' オブジェクトが渡された
    If IsObject(Item) Then _
        Call RaiseError( _
            a_Source:=ERR_SOURCE, _
            a_Description:="オブジェクトを渡すときは`Set`を使わなければいけない。")
            
    ' 既存のキーでない -> キーのコレクションに追加
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))
        
    m_Dictionary.Item(Key:=Key) = Item
End Property

Public Property Set Item( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Item property(Set)"
    
    ' 既存のキーでない -> キーのコレクションに追加
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))
        
    Set m_Dictionary.Item(Key:=Key) = Item
End Property

Public Property Let Key( _
            ByVal Key As Variant, _
            ByVal NewKey As Variant)
    Const ERR_SOURCE As String = "Key property(Let)"
    
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call RaiseError(ERR_SOURCE, "存在しないキーを指定してはいけない。")
    
    If m_Dictionary.Exists(Key:=NewKey) Then _
        Call RaiseError(ERR_SOURCE, "既存のキーに変更することはできない。")
    
    ' まず内部Dictionaryを更新
    m_Dictionary.Key(Key:=Key) = NewKey
    
    ' キーCollectionを詰め込み直すしかない……。
    Set m_KeyCollection = New Collection
    Dim k As Variant
    For Each k In m_Dictionary.Keys()
        Call m_KeyCollection.Add(Item:=k, Key:=CStr(k))
    Next
End Property

Public Sub Add( _
            ByVal Key As Variant, _
            ByVal Item As Variant)
    Const ERR_SOURCE As String = "Add() method(Sub)"
    
    ' 既存のキーにアイテムを設定しようとした
    If m_Dictionary.Exists(Key) Then
        Call RaiseError( _
            a_Source:=ERR_SOURCE, _
            a_Description:="既存のキーにはアイテムを設定できない。")
    End If
    
    Call m_KeyCollection.Add(Item:=Key, Key:=CStr(Key))
    
    Call m_Dictionary.Add(Key:=Key, Item:=Item)
End Sub

Public Function Exists(ByVal Key As Variant) As Boolean
    Exists = m_Dictionary.Exists(Key)
End Function

Public Function Keys() As Variant
    Keys = m_Dictionary.Keys
End Function

Public Function Items() As Variant
    Items = m_Dictionary.Items
End Function

Public Sub Remove(ByVal Key As Variant)
    Const ERR_SOURCE As String = "Remove() method"
    If Not m_Dictionary.Exists(Key:=Key) Then _
        Call RaiseError(ERR_SOURCE, "存在しないキーを指定してはいけない。")
    
    Call m_KeyCollection.Remove(Index:=CStr(Key))
    Call m_Dictionary.Remove(Key:=Key)
End Sub

Public Sub RemoveAll()
    Call m_Dictionary.RemoveAll
    Set m_KeyCollection = New Collection
End Sub

Public Function NewEnum() As IUnknown
    Set NewEnum = m_KeyCollection.[_NewEnum]
End Function

Private Sub RaiseError( _
            ByVal a_Source As String, _
            ByVal a_Description As String)
        ' エラーオブジェクトに渡すパラメータを用意
    Dim errNum As Long, errDesc As String, errSrc As String
    errNum = vbObjectError + 1
    errSrc = "Dictionary class: " & a_Source
    errDesc = "( ´,_ゝ`) < ﾌﾟｰｸｽｸｽｗ " & a_Description & "（クソが。）"
    
    ' 例外スロー
    Call Err.Raise( _
        Number:=errNum, _
        Source:=errSrc, _
        Description:=errDesc)
End Sub