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

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( _
            a_Source:=ERR_SOURCE, _
            a_Description:="要素追加後にCompareModeの変更はできない。")
    End If
    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

CompareModeプロパティの改善

CompareModeプロパティのDatabaseCompare

CompareModeプロパティの設定値はCompareMethod列挙体で指定しますが、その中のDatabaseCompareという設定値は、Microsoft Accessでしか意味を持ちません。

[『Microsoft Learn』の「Learn」 > 「VBA」 > 「CompareMode Property」の項]にも、

Microsoft Access only. Performs a comparison based on information in your database.

このように書いてあります。

……というわけで、Access以外のVBA環境で、CompareModeプロパティにDatabaseCompareが渡されたときのガードを追加しておきましょう。

ガードを実装する

「ガード」といっても、〝勝手にデフォルト値にフォールバックさせる〟というような対応では、わけもわからずにCompareModeプロパティにDatabaseCompareを設定してしまうような愚かなユーザに反省を促すことができません。

そこで、愚かなユーザに反省を促すために、親切な例外を吐くようにします。

ホストアプリケーション名を確認するには、ApplicationオブジェクトのNameプロパティを参照すれば良いので、次のように実装すれば良いでしょう。

リスト1

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

CompareModeプロパティに値を設定するときの話なので、Property Letプロシージャに追加します。

そもそも、VBAのホストアプリケーションがMicrosoft Accessだったら何の問題もないので、

If (Application.Name = "Microsoft Access") Then GoTo Finally

Finallyラベルまで飛ばしてしまいます。

そうすると、

If CompareMode = DatabaseCompare Then _
    Call RaiseError(ERR_SOURCE, "Access以外でDatabaseCompareを使ってはいけない。")

ここにたどり着くのはホストアプリケーションがMicrosoft Accessのときだけなので、シンプルに引数CompareModeの値をチェックするだけで済みます。

無用なIfのネスト防止につながるので、私はこの書き方を好みます。

あと、ついでに引数CompareModeに渡された値のチェックも追加しました。

If CompareMode < 0 Or CompareMode > 2 Then _
    Call RaiseError(ERR_SOURCE, "CompareMethod列挙体以外の値を渡してはいけない。")

引数の型をCompareMethodにしてあるので、入力中に

このようにヒントは出ますが、別にヒントを無視して-5とか114514のようなわけのわからない値を指定することもできてしまいます。

そして、わけのわからない値を設定してしまうと、

このように、何をどう反省したら良いのかよくわからないエラーメッセージが吐き出されます。

CompareMethod列挙体の実体は、0、1、2だけなので、

If CompareMode < 0 Or CompareMode > 2 Then

この条件に引っかかったときに例外をスローするようにしています。

動作確認

リスト1-1

Private Sub DictionaryTest01()
    Dim dic As Dictionary
    Set dic = New Dictionary
    dic.CompareMode = DatabaseCompare
End Sub

これを実行すると、

「Access以外でDatabaseCompareを設定することは許さん！」

というオブジェクト設計者の意図がよく伝わります。

リスト1-2

Private Sub DictionaryTest02()
    Dim dic As Dictionary
    Set dic = New Dictionary
    dic.CompareMode = 114514
End Sub

これを実行すると、

これまた、「CompareModeプロパティにCompareMethod以外のわけのわからない値を渡すことは許さん！」

という設計者の意図が良く伝わりますね。

おわりに

「カスタムDictionaryクラスを作ろう」シリーズは、これでいったんおしまい。

たとえば、Dictionaryインスタンスを

{"pachinko": 123, "slot": "123", "nobuta": "group"}

のようにシリアル化するToString()メソッドとか、中身が同じかどうかを判定するEquals()メソッドなんかを追加で実装してみたら、非常に使い勝手の良いデータオブジェクトになるのではないでしょうか。

追記

まあまあ大規模な見落としがあったので、まだまだ続きます。

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