DebugModule.bas

Option Explicit
Private Indent          As Integer
Private Prefix          As String
Private FH              As Object
Private FlagNotime          As Boolean
Private FlagDebugPrint  As Boolean

Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Sub DebugPrint(ByVal VarName As Variant, Optional ByVal Filename As String = "Debug.txt", _
               Optional ByVal TypeNameFlag As Boolean = False, Optional ByVal IndentCount As Integer = 4, _
               Optional NotimeFlag As Boolean = False, Optional DebugPrintFlag As Boolean = False)
    '必須：
    'VarName: データ構造を知りたい変数名を指定
    
    'オプション：
    'Indentcount: 配列、コレクション、Dictionaryなどネストして表示されるデータの全角スペースの数
    'TypeNameFlag:全ての型を表示したい時にTrue
    '----------------------------------------------------------------------------------------------
    
    '再帰呼出で、トップの時⇒追記状態でファイルオープンしておく
    If Indent = 0 Then
        FlagNotime = NotimeFlag
        FlagDebugPrint = DebugPrintFlag
        If Not FlagDebugPrint Then Call FileOpen(Filename)
    End If
    
    
    Dim i As Long
    Dim key As Variant
    If TypeName(VarName) = "Byte" Or TypeName(VarName) = "Integer" Or _
       TypeName(VarName) = "Long" Or TypeName(VarName) = "String" Or _
       TypeName(VarName) = "Single" Or TypeName(VarName) = "Double" Or _
       TypeName(VarName) = "Currency" Or TypeName(VarName) = "Date" Or _
       TypeName(VarName) = "Boolean" Or TypeName(VarName) = "Boolean" Then
        
        Call Output(TypeName(VarName), IndentCount, TypeNameFlag, VarName)

    ElseIf TypeName(VarName) = "Empty" Or TypeName(VarName) = "Null" Or _
           TypeName(VarName) = "Nothing" Or TypeName(VarName) = "Unknown" Then
        
        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
    ElseIf 0 < InStr(TypeName(VarName), "()") Then
        '2次元配列まで対応！3次元以上はNG!
        Dim temp As Integer, Dimension As Integer
        On Error Resume Next
        temp = UBound(VarName, 3)
        If Err.Number = 0 Then
            MsgBox "配列は3次元配列以上は未対応です"
            End
        End If
        
        Err.Clear
        temp = UBound(VarName, 2)
        Dimension = IIf(Err.Number = 0, 2, 1)
        On Error GoTo 0
        
        
        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
        '1次元配列か2次元配列かで処理を分岐
        Indent = Indent + 1
        If Dimension = 1 Then
        '1次元配列の処理
            For i = 0 To UBound(VarName)
                Prefix = "(" & i & "): "
                Call DebugPrint(VarName(i), IndentCount, TypeNameFlag)
            Next
            
        ElseIf Dimension = 2 Then
        '2次元配列の処理
            Dim ii As Long
            For i = 0 To UBound(VarName, 1)
                For ii = 0 To UBound(VarName, 2)
                    Prefix = "(" & i & "," & ii & "): "
                    Call DebugPrint(VarName(i, ii), IndentCount, TypeNameFlag)
                Next
            Next
        End If
        Indent = Indent - 1
    ElseIf TypeName(VarName) = "Collection" Then

        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
        Indent = Indent + 1
        For i = 1 To VarName.Count
            Prefix = i & ":"
            Call DebugPrint(VarName.Item(i), IndentCount, TypeNameFlag)
        Next
        Indent = Indent - 1
    
    ElseIf TypeName(VarName) = "Dictionary" Then

        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
        Indent = Indent + 1
        For Each key In VarName
            Prefix = "[" & TypeName(key) & "]" & key & " => "
            Call DebugPrint(VarName.Item(key), IndentCount, TypeNameFlag)
        Next
        Indent = Indent - 1
        
    End If
     
    '再帰呼出で、トップの時⇒追記状態でファイルオープンしておく
    If Indent = 0 And Not FlagDebugPrint Then Call FileClose
End Sub

Sub Output(ByVal TypeVarName As String, ByVal IndentCount As Integer, ByVal TypeNameFlag As Boolean, Optional ByVal VarName As Variant = "")
    If IndentCount < 0 Then IndentCount = 0
    
    Dim OutPutData As String
    If TypeNameFlag Then
        OutPutData = String(Indent * IndentCount, " ") & Prefix & "[" & TypeVarName & "]" & VarName & vbCrLf
            
        If FlagDebugPrint Then
            Debug.Print Replace(OutPutData, vbCrLf, "") '改行ははずす
        Else
            FH.Write OutPutData
        End If
    Else
        If 0 < InStrRev(Prefix, "]") Then
            Prefix = Right(Prefix, Len(Prefix) - InStrRev(Prefix, "]"))
        End If
        
        If 0 < InStr(TypeVarName, "()") Or TypeVarName = "Collection" Or TypeVarName = "Dictionary" Then
            OutPutData = String(Indent * IndentCount, " ") & Prefix & "[" & TypeVarName & "]" & VarName & vbCrLf
            
            If FlagDebugPrint Then
                Debug.Print Replace(OutPutData, vbCrLf, "") '改行ははずす
            Else
                FH.Write OutPutData
            End If
        Else
            OutPutData = String(Indent * IndentCount, " ") & Prefix & VarName & vbCrLf
            
            If FlagDebugPrint Then
                Debug.Print Replace(OutPutData, vbCrLf, "") '改行ははずす
            Else
                FH.Write OutPutData
            End If
        End If
    End If
    
    Prefix = ""
End Sub


Private Sub FileOpen(ByVal Filename As String)
    '.txtが省略されていたら追加する
    If 0 = InStr(Filename, ".txt") Then Filename = Filename & ".txt"
    
    Dim FSO As Object, FilePath As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    

    If FlagNotime Then
        FilePath = ThisWorkbook.Path & "\" & Filename
        Set FH = FSO.OPenTextFile(FilePath, 2, True)
    Else
        FilePath = ThisWorkbook.Path & "\(" & Replace(Time, ":", "") & ")" & Filename
        Set FH = FSO.OPenTextFile(FilePath, 8, True)
    End If
    
    Set FSO = Nothing
End Sub

Private Sub FileClose()
    FH.Close
    Set FH = Nothing
    
    Sleep (1000) '同名ファイルに出力されるのを避けるため、１秒時間をおいている
End Sub


'■SampleCode
Private Sub SampleCode1()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    '■配列データの出力を行います
    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    '※引数にデータ構造を見たい変数名を指定します
    '実行Excelファイルと同階層に (時間)Debug.txt として出力されます
    Call DebugPrint(varArray)
    '-----------------------------
    '[Variant()]
    '　　(0): 文字列
    '　　(1): 3
    '　　(2): True
    '-----------------------------
End Sub

Private Sub SampleCode2()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    '■Dictionaryの出力を行います
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    '※引数にデータ構造を見たい変数名を指定します
    '実行Excelファイルと同階層に (時間)Debug.txt として出力されます
    Call DebugPrint(varDic)
    '-----------------------------
    '※ファイルの出力結果
    '[Dictionary]
    '配列1 => [Variant()]
    '　　(0): 文字列
    '　　(1): 3
    '　　(2): True
    '配列2 => [Variant()]
    '　　(0): a
    '　　(1): b
    '　　(2): c
    '-----------------------------
    
    '対応している変数形式は
    'String/Integer/Long/Single/Double/Currency/Date/Boolean/Byte/Variant
    '上記を用いた、Collection/Dictionary/配列(2次元配列まで)
End Sub

Private Sub SampleCode3()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■複数出力したとき、何の変数を出力したものか判断がつきにくい！
    '　なんとかしてほしい
    '　⇒Filenameオプションにファイル名を指定してください
    Call DebugPrint(varArray, Filename:="Array.txt")
    Call DebugPrint(varDic, Filename:="Dictionary") '拡張子は書かなくても自動的.txtになります
End Sub


Private Sub SampleCode4()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■複数出力なんてしません！なのでファイル名に時間をつけて複数出力するのはやめてくれますか？
    '　何度も何度も消すのがめんどくさい。ゴミ箱がひどいことになる・・・
    '　⇒NotimeFlagオプションをTrueにしてください
    Call DebugPrint(varDic, Filename:="上書きテスト")
    Call DebugPrint(varDic, Filename:="上書きテスト") '通常だと(時間)上書きテスト.txt が時間ごとに作られる
    Call DebugPrint(varDic, Filename:="上書きテスト", NotimeFlag:=True)
    Call DebugPrint(varDic, Filename:="上書きテスト", NotimeFlag:=True)
    Call DebugPrint(varDic, Filename:="上書きテスト", NotimeFlag:=True) '上書きテスト.txt が一つだけ作られる(一番最後に実行したものだけが残る)
End Sub

Private Sub SampleCode5()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    'Q And A
    '■配列/Collection/Dictionaryでインデントされて出力
    '　されますが、あの幅が好みじゃない・・・。
    '　⇒IndentCountオプションを指定してください
    Call DebugPrint(varDic, IndentCount:=5)
    
    '-----------------------------
    '※ファイルの出力結果
    '[Dictionary]
    '　　　　　配列1 => [Variant()]
    '　　　　　　　　　　(0): 文字列
    '　　　　　　　　　　(1): 3
    '　　　　　　　　　　(2): True
    '　　　　　配列2 => [Variant()]
    '　　　　　　　　　　(0): a
    '　　　　　　　　　　(1): b
    '　　　　　　　　　　(2): c
    '-----------------------------
End Sub

Private Sub SampleCode6()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■データの型式を全てみたいです
    '　⇒TypeNameFlagオプションをTrueにしてください
    Call DebugPrint(varDic, TypeNameFlag:=True)
    
    '-----------------------------
    '※ファイルの出力結果
    '[Dictionary]
    '[String] 配列1 >= [Variant()]
    '　　(0): [String]文字列
    '　　(1): [Integer]3
    '　　(2): [Boolean]True
    '[String] 配列2 >= [Variant()]
    '　　(0): [String]a
    '　　(1): [String]b
    '　　(2): [String]c
    '-----------------------------
End Sub

Private Sub SampleCode7()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■ファイルじゃなくイミディエイトウィンドウにだしてよ
    '　⇒DebugPrintFlagをTrueにしてください
    Call DebugPrint(varDic, DebugPrintFlag:=True)
    
End Sub