VBAでの「debug.print」の内容を外部テキストファイルへ出力(少し変更)

昨日投稿しました "「debug.print」の内容を外部テキストファイルへ出力 " について、出力ファイル名に関する処理に少し手を加えました。

ファイル名に禁止文字が含まれていた場合、ファイル名全体を全角化して新ファイル名として出力するようになっていましたが、その部分の処理を、ファイル名の禁止文字のみ全角化するように変更しました。

例えば、ファイル名に「Now」関数を使用した場合、以下のような違いがあります。

---  昨日版  ---

(指定したファイル名) 2020/06/03 20:27:28.txt
(出力したファイル名) ２０２０／０６／０３　２０：２７：２８．ｔｘｔ.txt

文字全部を全角化しているので、ファイル名が長くなります。

--- 本日版  ---

(指定したファイル名) 2020/06/04 18:17:12.txt
(出力したファイル名) 2020／06／04 18：17：12.txt 

「/」と「:」のみ全角化しています。

******************

昨日版からのコード変更箇所は、特定文字を全角化する関数を追加しました。

ERROR_TRAP: の中で、以下の自作関数を呼び出しています。
Function ProhibitedCharactersNarrowToWide(chkName As String)

「禁止文字を半角から全角へ」という、英単語を並べただけの長いプロシージャ名になってしまいました。

実行方法は昨日と同じです。マクロコード中に以下の書式で記述します。

 PrintData2   出力したい文字列  ,  ファイル名 ,  出力フォルダフルパス

(ファイル名と出力パスは省略可能です。

プロシージャ名は、 PrintData  から  PrintData2  へ変更しています。

Sub PrintData2(prtDATA As Variant, _
                Optional fileName As String = "", _
                Optional dirPath As String = "")

'VBAでのマクロ実行中、VBEのイミディエイトウィンドゥに出力するdebug.printの内容を
'外部テキストファイルとして出力します。

'★Function ProhibitedCharactersNarrowToWide 関数とセットで使用してください。

'★ファイル名に禁止文字("\", "/", ":", "*", "?", "<", ">", "|")を使用した場合、
'★これらの文字のみ全角に変換します。

'出力ファイル名が同じ場合には、元のデータに追記(Append)します。
'指定ファイル名に、使用禁止文字が混じっていた場合は、ファイル名を全角化して保存。
'--------------------------------------------------
'使用例
'PrintData2 (prtDATA , [FileName,] [dirPath])

'・prtDATA  : 出力対象データ本体
'・FileName : 出力ファイル名 (省略可)
'・dirPath  : 出力フォルダフルパス (省略可)

'出力ファイル名と出力先フォルダフルパスを指定しない場合は以下を初期値に指定。
'出力ファイル名 = "VBAdebugPrin.txt"
'出力先フォルダフルパス = このマクロを実行しているブックと同一のフォルダ
'--------------------------------------------------

'Debug.Print "・prtDATA(出力文字本体。先頭30文字): _
    【" & Left(prtDATA, 30) & "】"
'Debug.Print "・FileName(出力ファイル名): _
    【" & fileName & "】"
'Debug.Print "・dirPath(出力先フォルダフルパス): _
    【" & dirPath & "】"
'Debug.Print "・dirPath(フォルダ存在確認結果): _
    【" & Dir(dirPath, vbDirectory) & "】"

'****************************************************
'ファイル名／フォルダパスが未指定のときのデフォルト値
Dim defFileName As String   '初期ファイル名
    defFileName = "VBAdebugPrint.txt"
Dim defDirPath As String    '初期出力フォルダパス
    defDirPath = ThisWorkbook.Path & "\"
'****************************************************

Dim outputFileName As String    '実際に使用するファイル名
    outputFileName = Trim(fileName)
    If fileName = "" Then
        outputFileName = defFileName
    End If
    If Right(LCase(outputFileName), 4) <> ".txt" Then
        outputFileName = outputFileName & ".txt"
    End If



Dim dirCheck As String  '出力先フォルダ存在確認
    dirCheck = Dir(dirPath, vbDirectory)
        'dirPathを指定しないとき、dirCheck = "."
        'dirPathが存在しないとき、dirCheck = ""
        'dirPathが存在するとき、dirCheck = dirPathの末端のフォルダ名

Dim outputPath As String    '実際の出力先フォルダ フルパス
    If dirCheck = "." Or dirCheck = "" Then
         outputPath = defDirPath
    Else
        outputPath = Trim(dirPath)
        If Right(outputPath, 1) <> "\" Then
            outputPath = outputPath & "\"
        End If
    End If
    
Dim fileNo As Byte  '使用可能なファイル番号(1～255)
    fileNo = FreeFile
Dim errCount As Byte    'ファイル名不正でのエラー発生カウンタ
    errCount = 0
    On Error GoTo ERROR_TRAP
    Open outputPath & outputFileName For Append As #fileNo
    On Error GoTo 0
    Print #fileNo, prtDATA
    Close #fileNo

PrintEnd:
Debug.Print prtDATA

Exit Sub
'--------------------------------------------------
ERROR_TRAP:

    If errCount = 0 Then
        'outputFileName = StrConv(outputFileName, vbWide) & ".txt"
        outputFileName = ProhibitedCharactersNarrowToWide(outputFileName)
        errCount = errCount + 1
        'Debug.Print "★ PrintDataの出力ファイル名を全角に変換。"
        'Debug.Print "★ → " & outputFileName
        Resume     'もう一度エラー発生行から実行
    Else
        '全角化でもエラーになるとき
        On Error GoTo 0
        Debug.Print "★ PrintDATAの出力中止(指定ファイル名異常)"
        GoTo PrintEnd
    End If
    
End Sub

'========================================

Function ProhibitedCharactersNarrowToWide(chkName As String)

'ファイル名として禁止されている文字の全角化

' \  円記号(バックスラッシュ)
' /  スラッシュ
' :  コロン
' *  アスタリスク
' ?  疑問符
' <> 不等号
' |  縦棒
' "  ダブルクォーテーション
'--------------------------------------------------
'(変換例)
'2020/06/04 17:57:11  → 2020／06／04 17：57：11
'--------------------------------------------------

Dim changeName As String
    changeName = chkName

Dim prohibitChara As Variant '変換対象文字群
    prohibitChara = Array("\", "/", ":", "*", "?", "<", ">", "|", """")

Dim chara As Variant
    For Each chara In prohibitChara
        If InStr(chkName, chara) > 0 Then
            changeName = Replace(changeName, chara, StrConv(chara, vbWide))
        End If
    Next chara

    ProhibitedCharactersNarrowToWide = changeName

End Function

'========================================

動作確認 

出力先は指定していませんので、このマクロコードが実行されたExcelブックと同じフォルダに出力しています。

Sub TEST_PrintData2()

'使用例
'PrintData2 (prtDATA , [FileName,] [dirPath])

'・prtDATA  : 出力対象データ本体
'・FileName : 出力ファイル名 (省略可)
'・dirPath  : 出力フォルダフルパス (省略可)


    PrintData2 "test1 *** ファイル名指定無し。 " & Now
    PrintData2 "test2 *** ファイル名に日時を指定。" & Now, Now & ".txt"
    PrintData2 "test3 *** ファイル名に日時を指定。" & Now, Now & ".txt"

    PrintData2 "test4 *** ファイル名指定無し。 " & Now
    PrintData2 "test5 *** ファイル名指定。" & Now, "書き込みテスト.txt"
    PrintData2 "test6 *** ファイル名指定。" & Now, "書き込みテスト.txt"

End Sub

★2021/3/6 追記。
ファイル名を指定する際、拡張子".txt" をつけ忘れた場合に、末尾に".txt"を付加するコードを追加しました。

Dim outputFileName As String    '実際に使用するファイル名
    outputFileName = Trim(fileName)
    If fileName = "" Then
        outputFileName = defFileName
    End If
    If Right(LCase(outputFileName), 4) <> ".txt" Then
        outputFileName = outputFileName & ".txt"
    End If