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