エビデンス(スクリーンショット)取得の省力化 for Excel 64bit
テスト実行とか、サーバー上での保守作業時にありがちな、スクリーンショット保存作業。通常だと以下の感じの作業の繰り返しになると思います。
それを少しだけでも省力化できないか、ってことで、以下のようなマクロが紹介されています。
motchi的プログラマブログ: エビデンス!エビデンス!!エビデンス!!! VBAでクリップボード監視
これを利用すると、結構いい感じ♪
Excel64bitで使おうとすると、少しだけ修正が必要だったので、修正後のVBAソースを貼り付けておきます。基本的にはLongPtrとLongあたりの修正のみですが。
' UserForm1 Private Sub CheckBox1_Change() If CheckBox1.Value = True Then Module1.catchClipboard Else Module1.releaseClipboard End If End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CheckBox1.Value = True Then Module1.releaseClipboard CheckBox1.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 Private Declare PtrSafe Function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongPtrW" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long 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 Const ROW_HEIGHT As Double = 13.5 Private hWndForm As LongPtr Private wpWindowProcOrg As Long Private hWndNextViewer As LongPtr Private firstFired As Boolean 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 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() Dim rowIdx As Integer With Sheet1 If .Shapes.Count > 0 Then With .Shapes(.Shapes.Count) rowIdx = (.Top + .Height) / ROW_HEIGHT + 4 End With Else rowIdx = 1 End If .Cells(rowIdx, 1).PasteSpecial End With End Sub
参考まで!