VBAで画像挿入マクロ

画像をある特定フォーマットの結合セルに中央寄せで貼り付けしたかった
ので、メモ書きです。

イメージ

VBAコード

'貼り付け基準位置
Public Const PST_INDEX As Long = 2
'貼り付け増加インデックス
Public Const ADD_INDEX As Long = 8
'余白設定
Public Const MARGIN As Long = 10
'写真の配置元
Public Const SRC_PATH As String = "C:\Users\user01\Desktop\test\写真張り付け用\"
'写真の配置シート
Public Const SRC_SHEET As String = "画像貼り付けテスト"

'関数呼び出しテスト
Public Sub test()
    Dim buf As String, cnt As Long
    Dim imgpath As String

    Application.ScreenUpdating = False
    cnt = 0

    '写真の配置元のjpg画像を読み出す
    buf = Dir(SRC_PATH & "*.jpg")

    Do While buf <> ""
        imgpath = SRC_PATH & buf
        Call PasteImg(imgpath, ThisWorkbook.Sheets(SRC_SHEET).Range("C" & PST_INDEX + cnt * ADD_INDEX))
        cnt = cnt + 1
        buf = Dir()
    Loop

    Application.ScreenUpdating = True

End Sub

'---------------------------------------------------
'画像中央揃え貼り付け関数
'---------------------------------------------------
'（引数）filepath:貼り付け対象画像ファイルパス
'        srcRange:貼り付け先rangeオブジェクト
'---------------------------------------------------
Private Sub PasteImg(filepath As String, ByVal srcRange As Range)

    Dim pic As Variant, dstw As Integer, dsth As Integer
    Dim hper As Single, wper As Single, avgh As Single, avgw As Single
    Dim dblScal As Double

    dstw = srcRange.MergeArea.Width
    dsth = srcRange.MergeArea.Height

    'ここでファイルパスの存在確認関数を使う。
    If IsFileExists(filepath) = False Then
        Application.ScreenUpdating = True
        Exit Sub
    End If

     '画像の貼り付け
    Set pic = ActiveSheet.Shapes.AddPicture( _
       Filename:=filepath, _
       LinkToFile:=False, _
       SaveWithDocument:=True, _
       Left:=0, _
       Top:=0, _
       Width:=0, _
       Height:=0)

    With pic
       .ScaleHeight 1, msoTrue
       .ScaleWidth 1, msoTrue

       '高さの縮尺(貼り付け先高さ/画像高さ)
       hper = srcRange.MergeArea.Height / .Height
       '幅の縮尺(貼り付け先幅/画像幅)
       wper = srcRange.MergeArea.Width / .Width

       '高さの縮尺 > 幅の縮尺
       If hper > wper Then
            .Height = .Height * wper - MARGIN
            .Width = srcRange.MergeArea.Width - MARGIN
       Else
          .Height = srcRange.MergeArea.Height - MARGIN
          .Width = .Width * hper - MARGIN
       End If

       '画像サイズが貼り付け先の高さを超えている
       If srcRange.MergeArea.Height <= .Height + MARGIN Then
            .LockAspectRatio = msoTrue
            dblScal = .Height / (srcRange.MergeArea.Height - MARGIN)
            .ScaleHeight dblScal, msoFalse, msoScaleFromTopLeft
       End If

       '中央へ調整
       avgh = (srcRange.MergeArea.Height / 2) - (.Height / 2)
       avgw = (srcRange.MergeArea.Width / 2) - (.Width / 2)
       .Top = srcRange.MergeArea.Top + avgh
       .Left = srcRange.MergeArea.Left + avgw
       Set pic = Nothing

    End With

End Sub

'---------------------------------------------------
'ファイル存在チェック
'---------------------------------------------------
'（引数）srcpath:チェックファイルパス
'---------------------------------------------------
Function IsFileExists(srcpath As String) As Boolean
    Dim rtn As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    rtn = FSO.FileExists(srcpath)

    Set FSO = Nothing
    IsFileExists = rtn
End Function