エビデンス作成支援？Excelアドイン #ExcelVBA

筆者がいてるような~~貧乏な~~エコノミーなプロジェクトでは、テストのエビデンスを作成する際に
・PrintScreenキーで画面をキャプチャ
・ペイントでトリムやマーキング
・Excelベースの資料に貼り付け
とやっているんですが、加工した画像をExcelに貼り付けようとするとまずA1セルに貼りついてしまうため、いちいち貼りなおさねばなりません

そのあとも、倍率調整したり枠線に色付けて・・・と細かい作業が続くので、この辺の一連の作業をワンクリックでできるようExcelのアドインマクロ化してみました。

Excelでアドイン形式のファイルを作成し、VBAに次のコードを記載します。
※Excel2013で半年ほど、2021で１ヶ月ほど使って問題は起こってませんが、不具合など気づかれた方はお知らせください

Option Explicit
Public VPb_前回倍率 As Integer    ' 前回入力値を覚える
Sub ShapeResize()

    On Error GoTo ErrTrap

    Dim vPr_縮小サイズ As Variant, vPr_倍率 As Single
    If IsNull(vPb_前回倍率) Or _
       vPb_前回倍率 = 0 Then
        vPb_前回倍率 = 70
    End If
    vPr_縮小サイズ = InputBox("縮小倍率（パーセント）は？", "倍率指定", vPb_前回倍率)
    If Trim(vPr_縮小サイズ) = "" Or _
       Not IsNumeric(vPr_縮小サイズ) Then
        Exit Sub
    Else
        vPb_前回倍率 = vPr_縮小サイズ
        vPr_倍率 = Clng(vPr_縮小サイズ) / 100
    End If

    Application.ScreenUpdating = False
    ' ***** クリップボード内容をペースト⇒カット⇒位置指定して再ペースト *****
    Dim vPr_カレント位置 As String
    vPr_カレント位置 = Activecell.Address        ' 貼り付け指定したセル位置を記憶
    ActiveSheet.Paste
    Selection.Cut
    Range(vPr_カレント位置).Select
    ActiveSheet.Paste

    ' 以下、お好みで調整ください
    With Selection.ShapeRange
        .ScaleHeight vPr_倍率, msoFalse, msoScaleFromTopLeft    ' 画像のリサイズ
        .ZOrder msoSendToBack                                   ' 画像の配置：最背面
        With .Line                                              ' 外枠を黒の細線で
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .Transparency = 0
            .Weight = 0.5
        End With
    End With

ErrTrap:
    Application.ScreenUpdating = True
    Exit Sub

End Sub

作成したアドインファイルを既定のフォルダ（一般にはC:\users\（ユーザー名）\AppData\Roaming\Microsoft\AddIns）配下に保存します。
Excelのオプション設定画面から「アドイン」－「管理：Excelアドイン」を選択して「設定」ボタンをクリックします。

　追加可能なアドインの一覧に、先ほど作成した処理（この場合Myconfig）が表示されるので、チェックを入れて「OK」ボタンをクリックします。
同じくExcelのオプション設定画面の「リボンのユーザー設定」で、「マクロ」を選ぶと先ほど記述したマクロ（この場合"ShapeResize"）が一覧に表示されます。
　これをリボンに追加すると、ボタンのワンクリックで指示した位置に、指定した倍率でetc.の画像を貼り付けることができます。