Excelにエビデンスを張り付けるのを自動化した話。

エビデンス取るのしんどかったので、張り付けるところをVBAで自動化しました。
スクリーンショットに保存した画像を自動でExcelに張り付けています。
以下のGifのようになります。 alt + prt src でウィンドウの画像をスクリーンショットに保存しています。
※ Gifミスってたのであとで張り替えます

VBAは全然触ったことがなく、いろいろなサイトを巡ってパクリまくったたくさん参考にしたのでググったら似たようなコードが出てくると思います。

使い方とコード

VBAで以下のコードを実行します。
実行状態でクリップボードに画像を保存すると自動でExcelに貼り付けられます。
Windows10なら Windows + shift + s で範囲を選択して画像をクリップボードに保存できます。
終わるときはexitを入力してEnterを押すなり、なにかエラーを起こせば終了できます。

画像貼り付け.bas

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

Sub クリップボードにコピーした画像を貼り付ける()
    OpenClipboard
    EmptyClipboard
    CloseClipboard
    Dim CB As Variant
    Dim position As Integer: position = 33
    Dim size As Double: size = 1
    Do While True
        CB = Application.ClipboardFormats
        If Not ActiveCell.Row = 1 Then
            If StrConv(ActiveCell.Offset(-1, 0).Value, vbUpperCase) = "EXIT" Then GoTo Quit
        End If
        On Error GoTo ErrorQuit
        For i = 1 To UBound(CB)
            If CB(i) = xlClipboardFormatBitmap Then
                ActiveSheet.Paste
                Set objShp = ActiveSheet.Shapes(Selection.name)
                objShp.LockAspectRatio = msoTrue
                objShp.ScaleHeight size, msoTrue
                ActiveCell.Offset(position, 0).Select
                OpenClipboard
                EmptyClipboard
                CloseClipboard
            End If
        Next i
        DoEvents
    Loop

Quit:
    MsgBox "停止しました。", vbInformation
    ActiveCell.Offset(-1, 0).ClearContents
    GoTo ToEnd
ErrorQuit:
    MsgBox "予期せぬ動作のため停止しました。", vbInformation
ToEnd:
End Sub

コードの解説

流れは以下の通りです。
クリップボードの処理用にライブラリをインポートします。
クリップボードを空にします。
変数設定をします。
ループを始めます。
クリップボードの中身を取得します。
もし、Exitが入力されたら処理を終了します。
エラーがある場合は処理を終了します。
クリップボードに画像があったらExcelに貼り付けます。
画像のサイズを直します。
次に画像を張る位置を設定します。
クリップボードを空にします。
制御をOSに移します。

クリップボードの処理用にライブラリをインポートします。

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

クリップボードを空にします。

    OpenClipboard
    EmptyClipboard
    CloseClipboard

変数設定をします。

    Dim CB As Variant 'クリップボードの中身を入れる変数
    Dim position As Integer: position = 33 ' 次に画像を張る位置 positionの分だけ下のセルを選択
    Dim size As Double: size = 1 ' 画像サイズ size倍

ループを始めます。

    Do While True
        '貼り付け処理
    Loop

クリップボードの中身を取得します。

        CB = Application.ClipboardFormats ' 中身は配列

Exitが入力されたら処理を終了します。

        ' 選択しているセルの1つ上にEXITが記入されていたらQuitに行く
        If Not ActiveCell.Row = 1 Then
            If StrConv(ActiveCell.Offset(-1, 0).Value, vbUpperCase) = "EXIT" Then GoTo Quit
        End If

Quit:
    MsgBox "停止しました。", vbInformation ' メッセージボックスを出す
    ActiveCell.Offset(-1, 0).ClearContents ' Exitの文字を消す
    GoTo ToEnd 'ToEndの後ろはEnd Subで処理が終わる

エラーがある場合は処理を終了します。

        On Error GoTo ErrorQuit ' エラーがあるときはErrorQuitへいく

ErrorQuit:
    MsgBox "予期せぬ動作のため停止しました。", vbInformation ' メッセージボックスを出す
    'この後ろはEnd Subで処理を終わる

クリップボードに画像があったらExcelに貼り付けます。

        For i = 1 To UBound(CB) 'クリップボードの中身の分繰り返す
            If CB(i) = xlClipboardFormatBitmap Then '画像かどうか確認する
                ActiveSheet.Paste ' クリップボードの画像を貼り付ける
            End If
        Next i

画像のサイズを直します。

                Set objShp = ActiveSheet.Shapes(Selection.name) ' 張り付けた画像を選択する
                objShp.LockAspectRatio = msoTrue ' サイズを変更しても元の比率を保持する
                objShp.ScaleHeight size, msoTrue ' 画像サイズをsize倍する

次に画像を張る位置を設定します。

                ActiveCell.Offset(position, 0).Select 'positionだけ下のセルを選択する

クリップボードを空にします。

                OpenClipboard
                EmptyClipboard
                CloseClipboard

制御をOSに移します。

        DoEvents 'ループ中に操作できるようにする

終わりです。

最後に

テスト疲れた……。
コードを書きたい……。