【Excel】ExcelVBA（マクロ）でキャプチャ画像を自動でシートに貼り付けるツールを作成してみた

'### API関数定義 ###'
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr

'### 基本情報定義 ###'
Private FileName As String
Private SheetName As String
Private CheckFlag As Boolean
Private BaseCell As Variant
Private LastRow As Long

'### クリップボードリセット ###'
Sub ClearClipboardImage()
    ' クリップボードを開く
    If OpenClipboard(0) <> 0 Then
        ' クリップボードから画像データを削除する
        EmptyClipboard
        ' クリップボードを閉じる
        CloseClipboard
    End If
End Sub

'### 画面キャプチャ開始 ###'
Sub StartCapture()
    MsgBox "画面キャプチャを開始します。"
    Application.OnKey "{ESC}", "StopCapture"
    CheckFlag = True
    ' 画面キャプチャの貼り付け先の情報を定義する
    FileName = "ScreenCaptureTool.xlsm"
    SheetName = "エビデンス"
    ' 画面キャプチャ終了フラグを定義する
    CheckFlag = True
    ' 画面キャプチャ開始時にクリップボードを一旦リセットする
    ClearClipboardImage
    ' 画面キャプチャ開始する
    ExeCaptute
End Sub

'### 画面キャプチャ貼り付け処理 ###'
Sub ExeCaptute()
    ' ESCキーでエラー処理に進む
    On Error GoTo ErrHandler
    
    ' クリップボードにビットマップ形式の画面キャプチャがあれば貼り付けする
    If Application.ClipboardFormats(1) = xlClipboardFormatBitmap Then
        Workbooks(FileName).Sheets(SheetName).Activate
        ' A列の最終行を取得する
        LastRow = Cells(Rows.Count, "A").End(xlUp).row
        ' キャプチャ取得日を貼り付け
        If Not IsEmpty(Workbooks(FileName).Sheets(SheetName).Range("A1")) And Trim(Workbooks(FileName).Sheets(SheetName).Range("A1").Value) <> "" Then
            Cells(LastRow + 58, "A").Value = "【取得日時：" & Now & "】"
            Cells(LastRow + 58, "A").Offset(1, 1).Select
        Else
            Cells(LastRow, "A").Value = "【取得日時：" & Now & "】"
            Cells(LastRow, "A").Offset(1, 1).Select
        End If
        Worksheets(SheetName).Paste
        Application.CutCopyMode = False
        ' 画面キャプチャのクリップボードをリセットする
        ClearClipboardImage
        ' シートに改ページを挿入する
        ActiveSheet.HPageBreaks.Add Before:=Cells(LastRow + 58, "A")
    End If
    ' 次回実行予定時刻を設定（1秒ごとに実行）
    Application.OnTime Now + TimeValue("00:00:01"), "ExeCaptute", , CheckFlag
    Exit Sub

' エラー処理
ErrHandler:
    CheckFlag = False
End Sub

'### 画面キャプチャ停止 ###'
Sub StopCapture()
    If CheckFlag = True Then
        CheckFlag = False
        Application.OnKey "{ESC}", ""
        MsgBox "画面キャプチャを停止します。"
    End If
End Sub

Sub DeleteAllCells()
    ' 「エビデンス」シートのすべてのデータとオブジェクトを削除する
    ThisWorkbook.Sheets("エビデンス").Cells.ClearContents
    ThisWorkbook.Sheets("エビデンス").DrawingObjects.Delete
    MsgBox "「エビデンス」シートをリセットしました。"
End Sub

Sub SaveEvidenceSheet()
    ' 保存時刻を取得
    Dim SaveTime As String
    SaveTime = Format(Now, "yyyymmdd_hhnnss")
    '名前をつけて保存
    Dim Save_File As Variant
    Save_File = Application.GetSaveAsFilename(InitialFileName:="作業エビデンス_" & SaveTime, _
    FileFilter:="Excelファイル,*.xlsx,すべてのファイル,*.*")
    ' キャンセルされた場合の処理
    If Save_File = False Then
        MsgBox "ファイルの保存をキャンセルしました。", vbInformation, "キャンセル"
        Exit Sub
    End If
    ' 既存のファイルを上書きするかしないかの判定
    If Dir(Save_File) <> "" Then
        msg = "同じ名前のファイルが他に存在します。上書きしますか？"
    If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
        ' メッセージ表示オフ
        Application.DisplayAlerts = False
    End If
    ' シートのコピー、ファイル保存
    Sheets("エビデンス").Copy
    ActiveWorkbook.SaveAs FileName:=Save_File, FileFormat:=xlOpenXMLWorkbook
    ' ファイルを閉じる
    ActiveWorkbook.Close
End Sub