Excelエビデンス作成の自動化

プログラムを動かしたときの出力ファイルやログ等を、ただ黙々とエクセルにペタペタ貼る作業ってモチベ上がらないしめんどい...(ログファイルを直で見ればよくね？)

あまりにも虚無過ぎたので、VBA全然分からないけどchatGPTを使って自動化マクロを作ってみた。

自動化した一連の流れの流れとしては下記の通り

ファイルを開く
↓
キャプチャ
↓
エクセルを新規で開く
↓
キャプチャをペースト
↓
保存

何行もあるような長いファイルには対応していないし、改善点だらけだが、とりあえず自分の環境的にはこれで十分

下記項目を設定シートに記載(Qiitaで表の作り方わかりません)
|項目　　　　　　　　　　　　|設定値　　　　　　　　　　　　　　 |
|:------------------------------------------------------------------|
|サクラエディタパス　　　　　| D:\Program Files\sakura\sakura.exe |
|出力ディレクトリ　　　　　　| C:\Output. |
|ファイル名フォーマット　　　| Evidence_No_. |
|シート名　　　　　　　　　　|証跡. |
|キャプチャ貼り付け開始位置　| B1. |
|テキストファイル名の取得　　| ON. |

VBAコード

Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, ByVal bScan As Byte, _
    ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Const VK_MENU As Byte = &H12       ' Altキー
Const VK_SNAPSHOT As Byte = &H2C   ' PrintScreenキー
Const KEYEVENTF_KEYUP As Long = &H2 ' キー解放フラグ

Sub GenerateEvidenceFiles()
    ' 設定シートを取得
    Dim wsSettings As Worksheet
    Set wsSettings = ThisWorkbook.Sheets("Settings")
    
    ' 設定値を取得
    Dim sakuraPath As String, outputDir As String, fileNamePrefix As String
    Dim sheetName As String, pasteCell As String, retrieveFileName As String
    
    sakuraPath = wsSettings.Cells(2, 2).Value
    outputDir = wsSettings.Cells(3, 2).Value
    fileNamePrefix = wsSettings.Cells(4, 2).Value
    sheetName = wsSettings.Cells(5, 2).Value
    pasteCell = wsSettings.Cells(6, 2).Value
    retrieveFileName = wsSettings.Cells(7, 2).Value
    
    ' 出力ディレクトリのチェック
    If Dir(outputDir, vbDirectory) = "" Then
        MsgBox "出力ディレクトリが見つかりません: " & outputDir, vbExclamation
        Exit Sub
    End If
    
    ' 実行リストシートを取得
    Dim wsExecutionList As Worksheet
    Set wsExecutionList = ThisWorkbook.Sheets("ExecutionList")
    
    Dim lastRow As Long
    lastRow = wsExecutionList.Cells(wsExecutionList.Rows.Count, 1).End(xlUp).Row
    
    If lastRow < 2 Then
        MsgBox "実行リストが空です。", vbExclamation
        Exit Sub
    End If
    
    ' 実行リストを1行ずつ処理
    Dim fileCount As Long
    fileCount = 0
    
    Dim textFilePath As String
    Dim i As Long
    
    For i = 2 To lastRow
        textFilePath = wsExecutionList.Cells(i, 1).Value
        
        ' テキストファイルが存在する場合のみ処理
        If Dir(textFilePath) <> "" Then
            fileCount = fileCount + 1
            Call CaptureTextFile(sakuraPath, textFilePath, outputDir, fileNamePrefix, fileCount, _
                                 sheetName, pasteCell, retrieveFileName)
        Else
            MsgBox "ファイルが見つかりません: " & textFilePath, vbExclamation
        End If
    Next i
    
    MsgBox "すべてのエビデンスファイルを生成しました。", vbInformation
End Sub

Sub CaptureTextFile(sakuraPath As String, textFilePath As String, outputDir As String, _
                    fileNamePrefix As String, fileCount As Long, sheetName As String, pasteCell As String, _
                    retrieveFileName As String)
    ' サクラエディタを終了
    Shell "taskkill /F /IM sakura.exe", vbHide
    Application.Wait (Now + TimeValue("0:00:01")) ' 少し待機
    
    ' サクラエディタでテキストファイルを開く
    Dim shellCommand As String
    shellCommand = """" & sakuraPath & """ """ & textFilePath & """"
    Shell shellCommand, vbNormalFocus
    Application.Wait (Now + TimeValue("0:00:02")) ' サクラエディタが開くのを待つ
    
    ' Excelブックの作成
    Dim wb As Workbook
    Set wb = Workbooks.Add
    
    ' 証跡シート作成
    Dim ws As Worksheet
    Set ws = wb.Sheets(1)
    ws.Name = sheetName
    
    ' 初期貼り付けセルを設定
    Dim targetCell As Range
    Set targetCell = ws.Range(pasteCell)
    
    ' テキストファイル名の取得がONの場合、ファイル名を記載
    If UCase(retrieveFileName) = "ON" Then
        targetCell.Offset(-1, 0).Value = "ファイル名: " & Dir(textFilePath)
    End If
    
    ' キャプチャの取得 (Alt + PrintScreen)
    keybd_event VK_MENU, 0, 0, 0        ' Alt 押下
    keybd_event VK_SNAPSHOT, 0, 0, 0   ' PrintScreen 押下
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0 ' PrintScreen 解放
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0     ' Alt 解放
    
    ' キャプチャの貼り付け
    targetCell.Select
    Application.Wait (Now + TimeValue("0:00:01"))
    ws.Paste
    
    ' Sheet1を削除 (不要シートの削除)
    If wb.Sheets.Count > 1 Then
        Application.DisplayAlerts = False
        wb.Sheets(1).Delete
        Application.DisplayAlerts = True
    End If
    
    ' 保存
    Dim outputFilePath As String
    outputFilePath = outputDir & "\" & fileNamePrefix & Format(fileCount, "000") & ".xlsx"
    wb.SaveAs outputFilePath
    wb.Close SaveChanges:=False
    
    ' 再度サクラエディタを終了
    Shell "taskkill /F /IM sakura.exe", vbHide
    Application.Wait (Now + TimeValue("0:00:01")) ' サクラエディタ終了待機
End Sub