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

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

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

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

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

Remove()メソッドの実装

最初に、仕様の確認。

Sub Remove(Key)

Scripting.Dictionaryのメンバー

指定したキーをディクショナリから削除します。

このようになっています。

「指定したキーをディクショナリから削除します」とは言うものの、まさか本当にキーだけを削除するなどということはあり得ないはずなので、〝指定したキーとアイテムのペア〟を削除するものと理解しましょう。

Remove()メソッドを実装する

リスト1
Public Sub Remove(ByVal Key As Variant)
    Call m_Dictionary.Remove(Key:=Key)
End Sub

これだけです。

Remove()メソッドを使ってみる

動作確認してみましょう。

リスト1-1
Private Sub DictionaryTest01()
    Dim dic As Dictionary
    Set dic = New Dictionary
    Call dic.Add(Key:="pachinko", Item:=123)
    Call dic.Add(Key:="slot", Item:="123")
    Debug.Print dic.Count
    Call dic.Remove(Key:="pachinko")
    Debug.Print dic.Count
    Debug.Print dic.Item(Key:="pachinko")
    Debug.Print dic.Item(Key:="slot")
End Sub
Call dic.Add(Key:="pachinko", Item:=123)
Call dic.Add(Key:="slot", Item:="123")

でDictionaryインスタンスdicに要素を2つ追加し、

Debug.Print dic.Count

で現時点での要素数をイミディエイト ウィンドウに出力します。

2が出力されるはずですね。

Call dic.Remove(Key:="pachinko")

ここでRemove()メソッドにより、キー"pachinko"の要素をポア！

Debug.Print dic.Count
Debug.Print dic.Item(Key:="pachinko")
Debug.Print dic.Item(Key:="slot")

で、

  • 現時点の要素数
  • キー"pachinko"の要素
  • キー"slot"の要素

をイミディエイト ウィンドウに出力します。

キー"pachinko"の要素はもはや存在しないためこのような出力になります。

カスタム例外を実装する

リスト1-2
Private Sub DictionaryTest02()
    Dim dic As Dictionary
    Set dic = New Dictionary
    Call dic.Add(Key:="pachinko", Item:=123)
    Call dic.Add(Key:="slot", Item:="123")
    Debug.Print dic.Count
    Call dic.Remove(Key:="nobuta")
End Sub

ところで、このようなコードで動作確認してみると、

Call dic.Remove(Key:="nobuta")

このように、Dictionaryインスタンスに存在しないキーを指定しているのでエラーになるはずです。

この通り。

アプリケーション定義またはオブジェクト定義のエラーです。

そして、例によって非常にわかりにくいエラーメッセージです。

そこで、例によって親切なエラーメッセージを吐くようにしておきます。

リスト1改
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

バッチリですね。

おわりに

次は、Remove()メソッドですね。

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

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