【VBA】ExcelVBAで実現するエビデンスツール

はじめに

インフラ系のエンジニアでWindowsServerやWebコンソール周りの操作をする際などにエビデンスとして画面のスクリーンショットを撮るといったことは結構定番かなと思います。

自分も新人の頃は「自分の身を守るためにもエビデンスを残すように！」と何度も忠告をうけたなーなんてことを思い出します。

エビデンスの残し方としてはWinshotのようなツールを利用して効率よくとっていくこともありますが、私の周りではExcelシートにべた張りしていく方法がよく用いられてましたね。

Excelエビデンスのメリット

Excelシートに貼り付けていくことは以下のようなメリットがあるかと思います。

• 単一のファイルで管理可能
• シートを分けることで、作業単位でエビデンスを記録できる
• 適宜コメントなどを書き込める(Excelだから)

とはいっても、以下のフローを毎回実施するのは面倒です。

1. 記録対象のウィンドウを開きprintscreenを押す
2. Excelにウィンドウを切り替える
3. 貼り付ける位置のセルを選択状態にする
4. ペーストする

今回はツールにより、先のフローの内2-4を自動化します。

ソースコード

ソースコードを見る

ソースコード

Option Explicit
'キャプチャ収集状態ならTrue
Private isLogging As Boolean

'キャプチャを貼り付けるブック名を保持する
Private fileName As String

'############################
'#キャプチャ取得プロシージャ
'############################
Private Sub Capture()
    On Error GoTo errorHandler
 
 'クリップボードに画像が格納されていたら貼り付ける
    If Application.ClipboardFormats(1) = xlClipboardFormatBitmap Then
       Dim rows As Integer: rows = 63 '行数
    
       'キャプチャを貼り付ける
       Workbooks(fileName).Activate 'マクロ実行時にfileName変数にアクティブbookの名前をいれる。
       
       '選択しているセルを基準セルとして取得する
       Dim baseCell As Variant
       Set baseCell = Selection
       
       'クリップボードのデータを貼付け、行数に合わせて縮小する
       baseCell.Offset(1, 1).Select
       ActiveSheet.Paste
       With Selection.ShapeRange
           .LockAspectRatio = msoTrue
           .Height = .Height * 0.7
       End With
       
       '次の画像を貼るために基準セルを移動し、クリップボードに現在のセルの値をコピーする(クリップボードの中身をBitmapでなくすため)
       With baseCell.Offset(rows + 1, 0)
           .Select
           .Copy
       End With
       
       '切り取り・コピーモードを解除する
       Application.CutCopyMode = False
       
       'Windows通知処理(外部PWスクリプトの実行)
        Dim PWobj
        Set PWobj = CreateObject("WScript.Shell")
        PWobj.Run ("Powershell -ExecutionPolicy RemoteSigned -Command <通知用Powershellスクリプト>"), 0
       
    End If
    
    '1秒間隔で再実行するようにタイマーをセットする
    Application.OnTime Now + TimeValue("00:00:01"), "Capture", , isLogging
    
    Exit Sub
    
errorHandler:
    isLogging = False
    
End Sub

'########################
'#キャプチャを開始する
'########################
Sub StartCapture()
    MsgBox "キャプチャの取得を開始します。終了時にはEscキーを押下してください。"
    
    'Escキーで停止できるようにしておく
    Application.OnKey "{ESC}", "StopCapture"
    
    'キャプチャを貼り付けるブック名を取得する
    fileName = ActiveWorkbook.Name
    
    'キャプチャ取得状態を設定する
    isLogging = True
    
    'キャプチャ実行中であることを示すためシート見出しを赤く塗りつぶす
    ActiveSheet.Tab.Color = RGB(255, 0, 0)
    
    'キャプチャの取得を開始する
    Capture
    
End Sub

'########################
'#キャプチャを終了する
'########################
Sub StopCapture()
    If isLogging = True Then
    
        'キャプチャの取得状態を解除する
        isLogging = False
        
        'ESCキーへの登録を解除する
        Application.OnKey "{ESC}", ""
        
        'シート見出しの色を戻す
        ActiveSheet.Tab.Color = RGB(0, 0, 0)
        
        MsgBox "キャプチャの取得を停止しました。"
        
    End If
    
End Sub

解説

プロシージャ

プロシージャ	説明
Capture	クリップボードにある画像データをExcelシートに一定の間隔で張り付ける。
StartCapture	Captureプロシージャを実行する
StopCapture	Captureプロシージャを停止する

CaptureはApplication.OnTimeメソッドにより、1秒間隔でループ実行されています。
つまるところ1度StartCaptureで動き出せば、StopCaptureを実行するまで止まりません。

StartCapture実行時にStopCaptureの実行をESCキーに割り当てているため、マクロ実行時はESCキーから停止可能。

クリップボードに画像が格納されていたら貼り付ける

If Application.ClipboardFormats(1) = xlClipboardFormatBitmap Then

エラー発生時用のGoto文の次はいきなりif文による判定です。
これはクリップボードに含まれているデータがビットマップかを判定してます。
Application.ClipboardFormatsメソッドはクリップボードに格納されたデータ形式に基づいて数値を返します。
Bitmapの場合9が返ります。
xlClipboardFormatBitmapは列挙型で定義されており中身は9です。
これにより、Bitmapの場合True判定として処理を続行します。

Falseの場合、Application.OnTimeまで飛びます。
→先頭からやり直し。

余談ですが、
この箇所でいまだに不明な点がひとつあります。
Application.ClipboardFormats()は()の中にindexを入れるのですが、
このインデックスは返す配列の要素を選択するそうです。
「クリップボードに記録されているデータがそれぞれ配列としてインデックスが割り振られていて、取り出したい要素を指定する」そんなイメージを持っていました。
つまり(2)としたら、２つ前のクリップボードのデータの形式を返すのかな？とか思いましたが、debug.printで値を確認しても一致しなかった…
しかも44なる値が返ってきて、列挙型にも定義されていない値でした。
自分の認識に誤りがありそうですが、これはちょっと気になりますね。

貼付け間隔を定義する

間隔

Dim rows As Integer: rows = 63 '行数

この間隔はディスプレイの解像度によって変わります。
また画像間隔をどの程度設けるのか好みがあると思いますので、
環境ごとに適宜修正頂くのが良いと思います。

図形のサイズを調整

図形サイズ調整

With Selection.ShapeRange
    .LockAspectRatio = msoTrue
    .Height = .Height * 0.7
End With

.LockAspectRatio = msoTrueとすることで図形のサイズを変更した場合も縦横比を維持させます。
.Height = .Height * 0.7で高さを調整します。
事前にmsoTrueとしているため、縦横比は保ちながらサイズ変更可能です。

ここも個人の趣向が強い箇所かと思いますので環境ごとに適宜設定頂くのがいいかなと思います。

ペースト完了時にWindows通知を出す

Application.OnTimeでCaptureプロシージャを無限ループしている訳だが、
気づかない間に処理が停止していてエビデンスが取れていなかった！
なんてことが起こったら元も子もない。
ということで、処理の最後にペースト処理が完了した旨のWindows通知を出す処理を入れます。

通知例)

Windows通知はWinRTのAPIを呼び出す必要があるがVBAで直接実行することはできない。
ここではPowerShellで通知スクリプトを作成しそれをVBAから呼び出す形にする。

トースト通知

$bodyText = 'ペースト処理が完了しました'

$ToastText01 = [Windows.UI.Notifications.ToastTemplateType, Windows.UI.Notifications, ContentType = WindowsRuntime]::ToastText01
$TemplateContent = [Windows.UI.Notifications.ToastNotificationManager, Windows.UI.Notifications, ContentType = WindowsRuntime]::GetTemplateContent($ToastText01)
$TemplateContent.SelectSingleNode('//text[@id="1"]').InnerText = $bodyText
$AppId = 'Microsoft.Office.EXCEL.EXE.15'
[Windows.UI.Notifications.ToastNotificationManager]::CreateToastNotifier($AppId).Show($TemplateContent)

ここで通知を出すアプリケーションのAppIDを指定する必要がある。
AppIDの確認は調べても中々思うように値を確認することができず苦戦したが、
以下のコマンドで取得できた。

AppIDの確認

get-StartApps

AppIDはAUMIDと記載されるケースもあるらしい

これをVBAから呼び出すが、PowershellスクリプトもVBAから直接呼び出すことができないため、
WSHを使って、スクリプトを呼び出す。

Psスクリプトの実行

Dim PWobj
Set PWobj = CreateObject("WScript.Shell")
PWobj.Run ("Powershell -ExecutionPolicy RemoteSigned -Command <Powershellスクリプト>, 0

runメソッドを使用することで外部コマンドを実行することができる。
これを利用して、Powershellを外部コマンドとして実行する。

Windows11環境での注意点

Windows11からPrintScreenキー押下時の挙動がsnnipingtoolの起動になった模様。
※以前は直接クリップボードに格納されていた。

これだと効率が落ちるため、
従来の設定に戻すことをお勧めします。

【設定方法】
[アクセシビリティ]-[キーボード]-[PrintScreen]キーを使用して画面キャプチャを開く→オフ

余談ですが、Windows10環境の時よりも通知のレスポンスが遅くなっている点がちょっと気になる点ですね。
コンパイルして実行速度上げた方がいいのかもしれない...

参考