動機
プログラマーではなくインフラ関連に従事しておりますが「エビデンス」「証跡」といって対象スクリーンショットを ([Alt] +) [PrtScn] キーの押下などで取得し Excel のシートにペーストする作業があります。これがかなり煩雑で多少なりとも自動化したい。
とりわけ Excel VBA はよくわかっていませんが、ありがたいことにすでに実現なさっている先達がいらっしゃいました。ただし、一部を自分ごのみに改変させていただきました。
出典
次の方々よりコードの肝の部分をそのまま頂戴しております。
以前の本投稿において、自力では、こちらのコードを 64 ビットに対応させようとSetWindowLong を SetWindowLongPtr におきかえると Excel アプリケーション本体が「落ち」たりして途方に暮れ、無限ループの方法を用いていました。
いまさらながらですが、よく検索してみるとちゃんと解決なさっている方がいらっしゃったのでした。お恥ずかしいかぎりです。
なお、次の記事を参考に 32 ビット用と 64 ビット用をひとつのコードにまとめてみました1。
動作確認環境
- Windows 10 Home 64-bit x64 20H2
- Microsoft Excel 2019
実装
別のブックを新規作成してそこにペーストするようにしました。そのブックに対応する Screenshots_yyyy-mm-dd_hhMMss.xlsx という形式のファイルをマイ ドキュメント フォルダーに作成します。
ThisWorkbook
フォームを閉じても「マクロ」から Begin をえらべば再開できます2。
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
Module1.Begin
End Sub
ユーザーフォーム
「挿入(I) > ユーザー フォーム(U)」より、キャプチャーの開始・中断用に「トグル ボタン」、日付・時刻挿入オプション用に「チェック ボックス」、終了するための「コマンド ボタン」を配置しました3。
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