仕事やプライベートで調べたことのメモ書きなど(@札幌)

仕事やプライベートで調べたこと、興味ある事のメモ書きです。2016年4月から札幌で働いてます。※このブログは個人によるもので、団体を代表するものではありません。

エビデンス(スクリーンショット)取得の省力化 for Excel 64bit

テスト実行とか、サーバー上での保守作業時にありがちな、スクリーンショット保存作業。通常だと以下の感じの作業の繰り返しになると思います。

  • PrtScで画面をコピーして
  • Excelに貼り付けて
  • Excelのシートをスクロールさせて

それを少しだけでも省力化できないか、ってことで、以下のようなマクロが紹介されています。

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

参考まで!