動機

プログラマーではなくインフラ関連に従事しておりますが「エビデンス」「証跡」といって対象スクリーンショットを ([Alt] +) [PrtScn] キーの押下などで取得し Excel のシートにペーストする作業があります。これがかなり煩雑で多少なりとも自動化したい。

とりわけ Excel VBA はよくわかっていませんが、ありがたいことにすでに実現なさっている先達がいらっしゃいました。ただし、一部を自分ごのみに改変させていただきました。

出典

次の方々よりコードの肝の部分をそのまま頂戴しております。

motchi的プログラマブログ: エビデンス！エビデンス！！エビデンス！！！　VBAでクリップボード監視その2

以前の本投稿において、自力では、こちらのコードを 64 ビットに対応させようとSetWindowLong を SetWindowLongPtr におきかえると Excel アプリケーション本体が「落ち」たりして途方に暮れ、無限ループの方法を用いていました。

いまさらながらですが、よく検索してみるとちゃんと解決なさっている方がいらっしゃったのでした。お恥ずかしいかぎりです。

エビデンス(スクリーンショット)取得の省力化 for Excel 64bit - 仕事やプライベートで調べたことのメモ書きなど（＠札幌）

なお、次の記事を参考に 32 ビット用と 64 ビット用をひとつのコードにまとめてみました¹。

VBA 32Bit版と64Bit版でDeclareステートメントの宣言を分ける方法 - Office 2010,2013 | ホームページ制作のサカエン Developer's Blog

動作確認環境

Windows 10 Home 64-bit x64 20H2
Microsoft Excel 2019

実装

別のブックを新規作成してそこにペーストするようにしました。そのブックに対応する Screenshots_yyyy-mm-dd_hhMMss.xlsx という形式のファイルをマイドキュメントフォルダーに作成します。

ThisWorkbook

フォームを閉じても「マクロ」から Begin をえらべば再開できます²。

ThisWorkbook

Option Explicit

Private Sub Workbook_Open()
    Module1.Begin
End Sub

ユーザーフォーム

「挿入(I) > ユーザーフォーム(U)」より、キャプチャーの開始・中断用に「トグルボタン」、日付・時刻挿入オプション用に「チェックボックス」、終了するための「コマンドボタン」を配置しました³。

UserForm1

Option Explicit

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub ToggleButton1_Change()
    If ToggleButton1.Value = True Then
        Module1.catchClipboard
        ToggleButton1.Caption = "Stop"
    Else
        Module1.releaseClipboard
        ToggleButton1.Caption = "Start"
    End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If ToggleButton1.Value = True Then
        Module1.releaseClipboard
        ToggleButton1.Value = False
    End If
End Sub

標準モジュール

Module1

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongPtrW" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
#Else
    Private Declare PtrSafe Function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If
Private Declare PtrSafe Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetClipboardViewer Lib "user32.dll" (ByVal hWndNewViewer As LongPtr) As LongPtr
Private Declare PtrSafe Function ChangeClipboardChain Lib "user32.dll" (ByVal hWndRemove As LongPtr, ByVal hWndNewNext As LongPtr) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal format As Long) As Long

Private Const GWL_WNDPROC As Long = -4
 
Private Const WM_DRAWCLIPBOARD As Long = &H308
Private Const WM_CHANGECBCHAIN As Long = &H30D
Private Const WM_NCHITTEST As Long = &H84
 
Private Const CF_BITMAP As Long = 2
 
Private hWndForm As LongPtr
Private wpWindowProcOrg As Long
Private hWndNextViewer As LongPtr
Private firstFired As Boolean

Private NewBook As Workbook

Public Sub catchClipboard()
    hWndForm = FindWindow("ThunderDFrame", UserForm1.Caption)
    wpWindowProcOrg = SetWindowLongPtr(hWndForm, GWL_WNDPROC, AddressOf WindowProc)
    firstFired = False
    hWndNextViewer = SetClipboardViewer(hWndForm)
End Sub
 
Public Sub releaseClipboard()
    Call ChangeClipboardChain(hWndForm, hWndNextViewer)
    Call SetWindowLongPtr(hWndForm, GWL_WNDPROC, wpWindowProcOrg)
End Sub
 
Public Function WindowProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Select Case uMsg
        Case WM_DRAWCLIPBOARD
            If Not firstFired Then
                firstFired = True
            ElseIf IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
                pasteToSheet 2, 2
            End If
            If hWndNextViewer <> 0 Then
                Call SendMessage(hWndNextViewer, uMsg, wParam, lParam)
            End If
            WindowProc = 0
        Case WM_CHANGECBCHAIN
            If wParam = hWndNextViewer Then
                hWndNextViewer = lParam
            ElseIf hWndNextViewer <> 0 Then
                Call SendMessage(hWndNextViewer, uMsg, wParam, lParam)
            End If
            WindowProc = 0
        Case WM_NCHITTEST
            WindowProc = 0
        Case Else
            WindowProc = CallWindowProc(wpWindowProcOrg, hWndForm, uMsg, wParam, lParam)
    End Select
End Function
 
Public Sub pasteToSheet(Optional ByVal targetRow As Integer = 1, Optional ByVal targetColumn As Integer = 1)
    Dim room As Integer
    
    room = 0
    NewBook.Activate
    With NewBook.ActiveSheet
        If .Shapes.Count > 0 Then
            targetRow = .Shapes(.Shapes.Count).BottomRightCell.Offset(1).Row
        End If
        If UserForm1.CheckBox1.Value = True Then
            room = 1
            .Cells(targetRow, targetColumn).NumberFormatLocal = "mm/dd"
            .Cells(targetRow, targetColumn).Value = Date
            .Cells(targetRow, targetColumn + 1).NumberFormatLocal = "hh:mm"
            .Cells(targetRow, targetColumn + 1).Value = Time
        End If
        .Cells(targetRow + room, targetColumn).Select
        .Paste
    End With
End Sub

Public Sub Begin()
    With UserForm1
        .Caption = "Start Capturing"
        .CheckBox1.Caption = "Insert date and time"
        .CommandButton1.Caption = "Quit"
        .ToggleButton1.Value = False
        .ToggleButton1.Caption = "Start"
        .Show vbModeless
    End With
    
    On Error GoTo ErrorHandler
    Set NewBook = Workbooks(ThisWorkbook.Worksheets(1).Range("A1").Value)
    Exit Sub
ErrorHandler:
    Set NewBook = Workbooks.Add
    NewBook.SaveAs CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Screenshots_" & format(Date, "yyyy-mm-dd_") & format(Time, "hhnnss")
    ThisWorkbook.Worksheets(1).Range("A1").Value = NewBook.Name
    ThisWorkbook.Activate
End Sub

その他の参考文献

詳細は控えますが職場の 32 ビット版でも動作しました。 ↩
A1 セルに名前が記録されているブックが開かれていることが必要です。 ↩
コードの記述には右クリックのコンテキストメニューから「コードの表示(O)」を選びます。またはフォームの図をダブルクリックします。 ↩