Help us understand the problem. What is going on with this article?

スクリーンショットをExcelシートに半自動でペーストする(エビデンス取得用)

動機

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

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

出典

主に次の方々1よりロジックおよびコード部分そのままを頂戴しております。

  1. エビデンス取得マクロツール(スクリーンショットキー押すだけ) - Qiita
  2. VBA 改良版 スクリーンショットを撮るたびに自動でシートに張り付けるマクロ ~ OnTimeによる恒常ループ - t-hom’s diary2
  3. motchi的プログラマブログ: エビデンス!エビデンス!!エビデンス!!! VBAでクリップボード監視 その23

動作確認環境

  • Windows 10 Home 64-bit x64 1809
  • Microsoft Excel 2019

実装

(2019/9/16 改良・機能追加)

ThisWorkbook

ブックを開くと実行されるようにしてみましたが、フォームを閉じても「マクロ」から Begin をえらべば再開できます。

ThisWorkbook
Private Sub Workbook_Open()
    Begin
End Sub

Sub Begin()
    With UserForm1
        .Caption = "Start Capturing"
        .CheckBox1.Caption = "Insert date and time"
        .CommandButton1.Caption = "Save & Quit"
        .ToggleButton1.Value = False
        .ToggleButton1.Caption = "Start"
        .Show vbModeless
    End With
End Sub

ユーザーフォーム

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

UserForm1
Option Explicit

Private Sub CommandButton1_Click()
    SaveWorksheetsAs Environ("UserProfile") & "\Documents\Evidence-" & Format(Date, "YYYYMMDD") & "-" & Format(Time, "HHMMSS") & ".xlsx", xlOpenXMLWorkbook
    Unload Me
End Sub

Private Sub SaveWorksheetsAs(ByVal Filename As Variant, ByVal FileFormat As Variant)
    Worksheets.Copy
    ActiveWorkbook.SaveAs Filename:=Filename, FileFormat:=FileFormat
End Sub

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

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If ToggleButton1.Value = True Then
        ToggleButton1.Value = False
    End If
    Application.Caption = ""
End Sub

標準モジュール

Module1
Option Explicit

Private Declare PtrSafe Function OpenClipboard Lib "user32" (Optional ByVal hWnd As Long = 0) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Sub AutoCapture()
    Dim CB As Variant
    Dim i As Integer
    Application.Caption = "Capturing"
    UserForm1.Caption = "Now Capturing"
Loop1:
    CB = Application.ClipboardFormats
    If CB(1) <> True Then
        For i = 1 To UBound(CB)
            If CB(i) = xlClipboardFormatBitmap Then
                Paste 2, 2
                ClearClipboard
                Exit For
            End If
        Next i
    End If
    DoEvents
    If UserForm1.ToggleButton1.Value = False Then
        Application.Caption = ""
        UserForm1.Caption = "Start Capturing"
    Else
        GoTo Loop1
    End If
End Sub

Private Sub ClearClipboard()
    OpenClipboard
    EmptyClipboard
    CloseClipboard
End Sub

Private Sub Paste(Optional ByVal targetRow As Integer = 1, Optional ByVal targetColumn As Integer = 1)
    Dim room As Integer
    room = 0
    With ThisWorkbook.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
        .Paste Destination:=.Cells(targetRow + room, targetColumn)
    End With
End Sub

実行例スクリーンショット

リモートデスクトップのなかで PrtScr してもローカルのブックにペーストされます。まだ職場の環境では試していませんが。
実行例スクリーンショット


  1. 職場のネットワークではこれらを含むブログ全般に規制がかかっていて容易には閲覧できません。 Qiita の記事は閲覧できます。 

  2. 通常のループと DoEvents では不具合があったとのことですが、当方の環境ではとくに問題ないようです。 

  3. こちらのクリップボードのイベントを監視する方法が理想的だと思いますが、当方の環境では動作せず SetWindowLongSetWindowLongPtr におきかえると Excel アプリケーション本体が「落ち」ました。 

  4. コードの記述には右クリックのコンテキストメニューから「コードの表示(O)」を選びます。またはフォームの図をダブルクリックします。 

Why do not you register as a user and use Qiita more conveniently?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away