見出し画像

Dictionaryの内容表示(VBA)

ちのみゆき

１．はじめに
　ExcelVBAで、連想記憶Dictionaryは、キーと要素（アイテム）の対を格納するオブジェクトです。対の個数を意識する必要もありませんし（メモリの都合で上限はあるでしょうけれど）、いろいろな要素を格納できるので、とても便利です。
　ですが、デバッグの時にVBAのエディタ（VBE）では、キーと要素の個数はローカルウィンドウで見ることができますが、要素の内容を見ることができません（図1）。これではとても不便なので、デバッグ時にDictionaryの内容を表示するツールを作成しました。

図1.デバッグ時のローカルウィンドウ

2.使用例
　以下のコードでDictionaryにデータを与えます。Stop文で動作を停止した時に、作成したツールを使って内容を表示したものが図２です。コードはわざとDictionaryがややこしくなるようにしてあります。

Public Sub test_dpdic()
    Dim dicA As New Dictionary
    Dim dicAa As New Dictionary
    Dim dicAb As New Dictionary
    Dim aryC As Variant
    
    Dim i As Long
    For i = 0 To 10
        dicAa(dicAa.Count) = i
        dicAb(CStr(i)) = 2 * i ^ 2 - 3 * i + 4
    Next

    aryC = Array("abc", "def", 3.14, 2, 72, "ghi")

    Set dicA("a") = dicAa
    Set dicA("b") = dicAb
    dicA("c") = aryC
    dicA(dicA.Count) = 123
    dicA(dicA.Count) = 256
    dicA(dicA.Count) = dicAb.Keys
    dicA(dicA.Count) = dicAb.Items
    Stop
End Sub

表示形式は
(Key[型])=データ[型]
要素が配列の時は
(Key[型])=(添字)データ[型],(添字)データ[型],….
要素がDictionaryの時は
(Key[型])=
(Key[Dictionary])=データ[型]
などと表示されます。

図２.ツールの表示結果

３.使い方
　ステップ実行している時、Stop文で止めた時、エラーが出てデバッグモードにした時などに、VBEのイミディエイトウィンドウに
　　dpdic Dictionary名(Enter)
と入力する、イミディエイトウィンドウに図２のような結果が表示されます。
　上記は添付したファイルでVBEのModule1に
Public Sub test_dpdic()
として載せておきますので、コードと表示結果を見比べてみてください。
　ご利用になる時はModule_dpdicをそのまま標準モジュールに追加するのが簡単かと思います。
　ちなみにdpdicという名前は、debug print Dictionary という意味です。

４.ソースコード
　ソースコードは以下です。説明は省略します。


Option Explicit


'デバッグ用辞書内容表示
Public Sub dpDic(dic As Dictionary, Optional dictname As String = "dict", Optional inum As Long = -1)
    Dim msg As String
    msg = dictname & vbCrLf
    msg = getDic(dic, inum)
    
    Debug.Print msg
End Sub

'デバッグ用辞書内容取得
Private Function getDic(dic As Variant, inum As Long) As String
    '辞書が空(宣言してNewしていない)なら処理しない
    If dic Is Nothing Then
        getDic = "Nothing"
        Exit Function
    End If
    
    Dim keywd As Variant
    Dim itmdt As Variant
    Dim typkey As Variant
    Dim typitm As Variant
    Dim icnt As Long: icnt = 0
    Dim msg As String: msg = ""
    
    For Each keywd In dic.Keys '辞書のキーワードについて
        typkey = getTypeName(dic(keywd))
        typitm = getTypeName(dic(keywd))
        
        If typitm = "Dictionary" Then 'itemがDictionary
            msg = msg & BrRd("", keywd, BrSq("", typkey)) & "=" & vbCrLf
            msg = msg & getDic(dic(keywd), inum) '辞書内容を表示（再帰）
            msg = msg & vbCrLf '辞書の表示が終わった時は見やすさのため改行する
        ElseIf typitm = "Data" Then 'itemがData型
            msg = msg & BrRd("", keywd, BrSq("", typkey)) & "=" 'keywordを表示
            itmdt = dic(keywd) 'item
            msg = msg & getAry(itmdt) 'itemを表示
        Else 'itemがObject
            msg = msg & BrRd("", keywd, BrSq("", typkey)) & "=" 'keywordを表示
            msg = msg & typitm 'itemのオブジェクト名を表示
        End If
        If Mid(msg, Len(msg), 1) = "," Then
            msg = Left(msg, Len(msg) - 1)
        End If
        msg = msg & vbCrLf
        icnt = icnt + 1
        If icnt > inum And inum > 0 Then Exit For
    Next
    msg = Replace(msg, vbCrLf & vbCrLf, vbCrLf)
    getDic = msg
End Function

'デバッグ用配列内容表示
Public Sub dpAry(xvar As Variant, Optional vname As String = "var")
    Dim msg As String
    msg = vname & vbCrLf
    msg = getAry(xvar)

    Debug.Print msg
End Sub

Private Function getAry(xvar As Variant) As String
    Dim msg As String
    msg = ""
    
    Dim vinfo As Variant
    vinfo = getVinfo(xvar)
    If vinfo(1) = 0 Then
        msg = msg & getAry0(xvar)
    ElseIf vinfo(1) = 1 Then
        msg = msg & getAry1(xvar)
    ElseIf vinfo(1) = 2 Then
        msg = msg & getAry2(xvar)
    ElseIf vinfo(1) = 3 Then
        msg = msg & getAry3(xvar)
    Else
        msg = msg & "非対応"
    End If

    getAry = msg

End Function


Private Function getAry0(ary As Variant) As String
    Dim msg As String
    msg = ary & BrSq("", TypeName(ary)) & ","
    getAry0 = msg
End Function

'デバッグ用1次元配列内容取得
Private Function getAry1(ary As Variant) As String
    Dim vinfo As Variant
    Dim msg As String
    msg = ""
    
    Dim i As Long
    For i = LBound(ary) To UBound(ary)
        vinfo = getVinfo(ary(i))
        msg = msg & BrRd("", i)
        If vinfo(1) = 0 Then
            msg = msg & getAry0(ary(i))
        ElseIf vinfo(1) = 1 Then
            msg = msg & getAry1(ary(i))
        ElseIf vinfo(1) = 2 Then
            msg = msg & getAry2(ary(i))
        ElseIf vinfo(1) = 3 Then
            msg = msg & getAry3(ary(i))
        Else
            msg = msg & "非対応 次元" & vinfo(1)
        End If
    Next

    msg = msg & vbCrLf
    getAry1 = msg
End Function

'デバッグ用２次元配列内容取得
Private Function getAry2(ary As Variant) As String
    Dim vinfo As Variant
    Dim msg As String
    msg = ""
    Dim i As Long, j As Long
    
    For i = LBound(ary) To UBound(ary)
        For j = LBound(ary, 2) To UBound(ary, 2)
            vinfo = getVinfo(ary(i, j))
            msg = msg & BrRd(",", i, j)
            If vinfo(1) = 0 Then
                msg = msg & getAry0(ary(i, j))
            ElseIf vinfo(1) = 1 Then
                msg = msg & getAry1(ary(i, j))
            ElseIf vinfo(1) = 2 Then
                msg = msg & getAry2(ary(i, j))
            ElseIf vinfo(1) = 3 Then
                msg = msg & getAry3(ary(i, j))
            Else
                msg = msg & "非対応 次元" & vinfo(1)
            End If
            msg = msg & vbCrLf
        Next
        msg = msg & vbCrLf
    Next
    getAry2 = msg
End Function

'デバッグ用３次元配列内容取得
Private Function getAry3(ary As Variant) As String
    Dim vinfo As Variant
    Dim msg As String
    msg = ""
    Dim i As Long, j As Long, k As Long
    
    For i = LBound(ary) To UBound(ary)
        For j = LBound(ary, 2) To UBound(ary, 2)
            For k = LBound(ary, 2) To UBound(ary, 3)
                vinfo = getVinfo(ary(i, j, k))
                msg = msg & BrRd(",", i, j, k)
                If vinfo(1) = 0 Then
                    msg = msg & getAry0(ary(i, j, k))
                ElseIf vinfo(1) = 1 Then
                    msg = msg & getAry1(ary(i, j, k))
                ElseIf vinfo(1) = 2 Then
                    msg = msg & getAry2(ary(i, j, k))
                ElseIf vinfo(1) = 3 Then
                    msg = msg & getAry3(ary(i, j, k))
                Else
                    msg = msg & "非対応 次元" & vinfo(1)
                End If
                msg = msg & vbCrLf
            Next
            msg = msg & vbCrLf
        Next
        msg = msg & vbCrLf
    Next
    getAry3 = msg
End Function

Private Function BrRd(sep As String, ParamArray x() As Variant) As Variant
    Dim msg As String
    msg = "(" & Join(x, sep) & ")"
    BrRd = msg
End Function

Private Function BrSq(sep As String, ParamArray x() As Variant) As Variant
    Dim msg As String
    msg = "[" & Join(x, sep) & "]"
    BrSq = msg
End Function

Private Function BrWv(sep As String, ParamArray x() As Variant) As Variant
    Dim msg As String
    msg = "{" & Join(x, sep) & "}"
    BrWv = msg
End Function

'変数が配列か調べる
Private Function CkAry(xdim As Variant) As Boolean
    Dim flg As Boolean
    If InStr(1, TypeName(xdim), "()") > 0 Then
        flg = True
    Else
        flg = False
    End If
    CkAry = flg
End Function

'配列の次元を調べる
Private Function getDim(xdim As Variant) As Long
    Dim i As Long, iUB As Long
    On Error GoTo 9999
    For i = 1 To 100
        iUB = UBound(xdim, i)
    Next i
    
9999:
    getDim = i - 1
End Function

'変数のタイプを返す。データ型はData、オブジェクトはその名前を返す。
Private Function getTypeName(xvar As Variant) As String
    Dim tpname As String 'TypeNqame
    tpname = TypeName(xvar)
    If InStr(1, tpname, "()") > 0 Then '()を外す
        tpname = Left(tpname, Len(tpname) - 2)
    End If
    
    Dim ret As String
    Select Case tpname
        Case "Byte", "Integer", "Long", "LongLong", "Single", "Double"
            ret = "Data"
        Case "Currency", "Decimal", "Date", "String", "Boolean"
            ret = "Data"
        Case "Variant" 'Data型ではないときに、どう処理するのか
            ret = "Data"
        Case Else
            ret = tpname
    End Select
    
    getTypeName = ret
End Function

Private Function getVinfo(xvar As Variant) As Variant
    getVinfo = Array(TypeName(xvar), getDim(xvar))
End Function

Public Sub CK(xvar As Variant)
    Debug.Print "Ary? "; CkAry(xvar)
    Debug.Print "Dim = "; getDim(xvar)
    Debug.Print "Type= "; getTypeName(xvar)
End Sub

５．Excelファイル
　Excelファイルを添付します。上述したものがすべて入っています。

　自由に利用、改変、再配布していただいて構いません。無いと思いますが、これを販売することだけは、おやめください。

以上です。

#Excel , #VBA , #Dictionary , #連想記憶 , #デバッグ

応援してやろうということで、お気持ちをいただければ嬉しいです。もっと勉強したり、調べたりする糧にしたいと思います。