画像をExcelにひたすら貼り付けるマクロ

背景

画面のハードコピーを大量に取得した後、Excelに貼り付けて『・・・を実行した』とか『・・・が確認できた』のような説明を記載する苦行がある。説明を書くのは自動化できないが、ハードコピーを貼り付ける手間は自動化により省けるよね、ということで。

仕様(大雑把)

ファイル選択ダイアログで貼り付けるファイルを複数選択する
リサイズはしない
貼り付けの際に、説明を記述するために2行ほど空けさせる

マクロ

'PastePicturesマクロ
Sub PastePictures()
    Dim filenames As Variant, filename As Variant
    
    filenames = Application.GetOpenFilename( _
        FileFilter:="画像ファイル,*.png;*.jpg", _
        MultiSelect:=True)
    If IsArray(filenames) Then
        For Each filename In filenames
            '画像間を2行空ける
            PastePicture CStr(filename), 2
        Next filename
    End If
End Sub

Sub PastePicture(filename As String, offset As Integer)
    Dim picture As Shape
    
    Set picture = ActiveSheet.Shapes.AddPicture( _
        filename:=filename, _
        LinkToFile:=False, SaveWithDocument:=True, _
        Left:=Selection.Left, Top:=Selection.Top, _
        Width:=0, height:=0)

    picture.ScaleHeight 1!, msoTrue
    picture.ScaleWidth 1!, msoTrue
    'picture.heightはポイント単位
    '(ピクセル単位に変換するには96/72を掛ける)
    MoveDown picture.height, offset
End Sub

Sub MoveDown(pt As Double, offset As Integer)
    Dim moved As Double
    
    moved = 0
    Do While moved <= pt
        'ActiveCell.heightはポイント単位
        moved = moved + ActiveCell.height
        ActiveCell.offset(1, 0).Activate
    Loop
    ActiveCell.offset(offset, 0).Activate
End Sub

Excel 2010 とそれより前の Excel では貼り付け時の動作が異なるので Shapes.AddPicture を使う。貼り付けたのがリンクだけで、画像ファイルを消すと参照不可なんてハードコピーを貼り付けるようなシチュエーションでは最もまずい状況。怖い怖い。Shapes.AddPicture であればきちんと Excel ファイル内に保存してくれる。