DictionaryをDumpしたい１

実は、Dictionary・・・好きなんですよ。
分かる方には分かると思います。

但し、VBAを扱う人でDictionaryを避ける人の気持ちも分かります。
ブレークポイントでチェックするとですね・・・

"値"の所で表示されるのはKeyです。Valueについてはローカルウィンドウで
表示されないんです。(＝確認出来ない)

でも、好きなんですよ。メソッドを持たないオブジェクトのようなものなので。

Valueをローカルウィンドウで表示させる方法は、恐らくないと思うので、
何とかしてイミディエイトウィンドウに出力したいんです。

今までも何度か紹介している"Ariawase"ですが、こちらの"Core.bas"の
中にDump関数があります。
ariawase/src/Ariawase.xlsm/Core.bas at master · vbaidiot/ariawase · GitHub

これをちょっと試す事にします。

Option Explicit

Sub dump_test()
    Debug.Print Dump(5)
    Debug.Print Dump(Array(5, "55", 7))
    Debug.Print Dump(Array(5, Array(5, 2), 7))
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim dict2 As Object
    Set dict2 = CreateObject("Scripting.Dictionary")
    dict2.Add "5", 15
    dict2.Add "6", 16
    dict.Add "7", 17
    dict.Add "8", 18
    dict.Add 9, dict2
    Debug.Print Dump(dict)
    
    Dim lst As New Collection
    lst.Add 5
    Debug.Print Dump(lst)
    
End Sub

あっ中身には意味が無いので。

実行するとこんな感じです。

5%
Array(5%, "55", 7%)
Array(5%, Array(5%, 2%), 7%)
Dictionary
Collection

配列に関してはキッチリ出力してくれるのですが、オブジェクトに関しては
オブジェクト名のみの出力です。
まぁ確かにそうなのですが、DictionaryをやっぱりDumpしたいんです。

そこで、ちょっとDump関数と関連する関数をちょっとお借りして、
配列の出力を参考にこんな感じで修正してみました。

''' @param x As Variant
''' @return As String
Function Dump( _
        ByVal x As Variant) As String

    Dim ty As String: ty = TypeName(x)
    Select Case ty
        Case "Boolean":     Dump = x
        Case "Integer":     Dump = x & "%"
        Case "Long":        Dump = x & "&"
        #If Win64 Then
        Case "LongLong":    Dump = x & "^"
        #End If
        Case "Single":      Dump = x & "!"
        Case "Double":      Dump = x & "#"
        Case "Currency":    Dump = x & "@"
        Case "Byte":        Dump = "CByte(" & x & ")"
        Case "Decimal":     Dump = "CDec(" & x & ")"
        Case "Date":
            Dim d As String, t As String
            If Abs(x) >= 1 Then d = Month(x) & "/" & Day(x) & "/" & Year(x)
            If Not IsInt(x) Then t = Format(x, "h:nn:ss AM/PM")
            Dump = "#" & Trim(d & " " & t) & "#"
        Case "String"
            If StrPtr(x) = 0 Then
                Dump = "vbNullString"
            Else
                Dump = """" & Replace(x, """", """""") & """"
            End If
        Case "Error"
            If IsMissing(x) Then
                Dump = "Missing"
            Else
                Dump = "CVErr(" & ReMatch(CStr(x), "\d+")(0) & ")"
            End If
        Case "ErrObject"
            Dump = "Err " & x.Number
        Case "Empty", "Null", "Nothing", "Unknown"
            Dump = ty
        Case Else
            If IsObject(x) Then
                If ty = "Dictionary" Then
                    Dim keys As Variant
                    keys = x.keys()
                    Dim ar2 As Variant
                    ReDim ar2(x.Count - 1)
                    Dim j As Long
                    For j = 0 To x.Count - 1: ar2(j) = Dump(keys(j)) & ":" & Dump(x(keys(j))): Next
                    Dump = "Dictionary(" & Join(ar2, ", ") & ")"
                Else
                    Dump = ToStr(x)
                End If
            ElseIf IsArray(x) Then
                Dim rnk As Integer: rnk = ArrRank(x)
                If rnk = 1 Then
                    Dim lb As Long: lb = LBound(x)
                    Dim ub As Long: ub = UBound(x)
                    Dim ar As Variant
                    If ub - lb < 0 Then
                        ar = Array()
                    Else
                        Dim mx As Long: mx = 8 - 1
                        Dim xb As Long: xb = IIf(ub - lb < mx, ub, lb + mx)
                        ReDim ar(lb To xb)
                        Dim i As Long
                        For i = lb To xb: ar(i) = Dump(x(i)): Next
                    End If
                    Dump = "Array(" & Join(ar, ", ") & IIf(xb < ub, ", ...", "") & ")"
                Else
                    Dump = Replace(ty, "()", "(" & String(rnk - 1, ",") & ")")
                End If
            Else
                Err.Raise 51
        End If
    End Select
End Function


''' @param num As Variant(Of Numeric Or Date)
''' @return As Boolean
Function IsInt( _
        ByVal num As Variant) As Boolean

    If IsDate(num) Then num = CDbl(num)
    If Not IsNumeric(num) Then Err.Raise 13
    
    IsInt = num = Fix(num)

End Function


''' @param expr As String
''' @param ptrnFind As String
''' @param iCase As Boolean
''' @return As Variant(Of Array(Of String))
Private Function ReMatch( _
        ByVal expr As String, ByVal ptrnFind As String, _
        Optional ByVal iCase As Boolean = False) As Variant
    
    Dim ret As Variant: ret = Array()
    
    Dim regex As Object:  Set regex = CreateRegExp(ptrnFind, IIf(iCase, "i", ""))
    Dim ms As Object:     Set ms = regex.Execute(expr)
    If ms.Count < 1 Then: GoTo Ending
    
    Dim sms As Object:    Set sms = ms(0).SubMatches
    ReDim ret(sms.Count)
    
    ret(0) = ms.Item(0).Value
    Dim i As Integer
    For i = 1 To UBound(ret): ret(i) = sms.Item(i - 1): Next
    
Ending:
    ReMatch = ret
End Function


''' @param x As Variant
''' @return As String
Private Function ToStr(ByVal x As Variant) As String
    If IsObject(x) Then
        On Error GoTo Err438
        ToStr = x.ToStr()
        On Error GoTo 0
    ElseIf IsArray(x) Then
        ToStr = TypeName(x)
    Else
        ToStr = x
    End If
    
    GoTo Escape
    
Err438:
    Dim e As ErrObject: Set e = Err
    Select Case e.Number
        Case 438: ToStr = TypeName(x): Resume Next
        Case Else: Err.Raise e.Number, e.source, e.Description, e.HelpFile, e.HelpContext
    End Select
    
Escape:
End Function


''' @param arr As Variant(Of Array(Of T))
''' @return As Integer
Private Function ArrRank( _
        ByVal arr As Variant) As Integer
        
    If Not IsArray(arr) Then Err.Raise 13
    
    Dim x As Long
    Dim i As Integer: i = 0
    On Error Resume Next
    While Err.Number = 0: x = UBound(arr, IncrPre(i)): Wend
    ArrRank = i - 1

End Function


''' @param n As Variant
''' @param stepVal As Variant
''' @return As Variant
Private Function IncrPre( _
        ByRef n As Variant, _
        Optional ByVal stepVal As Variant = 1) As Variant

    n = n + stepVal: IncrPre = n

End Function

長いのですが、僕が書き替えたのは数行です・・・。

で、最初のテストコードを再度実行するとこんな感じです。

5%
Array(5%, "55", 7%)
Array(5%, Array(5%, 2%), 7%)
Dictionary("7":17%, "8":18%, 9%:Dictionary("5":15%, "6":16%))
Collection

見易いかどうかは別として、何とか中身の出力に成功です。

ん？Collectionの出力は？　って言いたいんですよね。
ローカルウィンドウで確認出来るから取りあえずはこのままで。

本音を書くとキー付きのCollectionの扱いを思い付かなかったので
止めました。

改めて思うのですがAriawaseは桁違いにすごい。