Excel マクロ(VBA) で対象セルに画像を張り付ける

備忘録としてVBAマクロを掲載していくシリーズ。

指定したセル上に、セルに寸法を合わせた画像を貼り付ける処理。
指定したセルが結合されたセルの場合、結合したセル全体のサイズに合わせる。

まずコア部分。

引数は下記の通り。
tgtRange : 貼り付ける先のセル（結合セルの場合は左上のセルを指定。)
fname : 貼り付ける画像のパス(省略した場合は、対象のセルに記入されたパスを参照する)

Function 対象セルに画像を張り付ける(ByRef tgtRange, Optional fname As String)

     If fname = "" Then
          If tgtRange.Text = "" Then Exit Function
          fname = Replace(ActiveWorkbook.FullName, _
                      ActiveWorkbook.Name, "") & tgtRange.Text
     End If

     ' 貼り付け位置・サイズの調整
     ' ( Width, Heightの指定が必須のため、仮の値を設定 )
     Dim objShape
     Set objShape = tgtRange.Parent.Shapes.AddPicture( _
          Filename:=fname, _
          LinkToFile:=False, _
          SaveWithDocument:=True, _
          Left:=tgtRange.Left + 1, _
          Top:=tgtRange.Top + 1, _
          Width:=tgtRange.MergeArea.Width, _
          Height:=tgtRange.MergeArea.Height)
     With objShape
          .ScaleHeight 1, msoTrue
          .ScaleWidth 1, msoTrue
          '.LockAspectRatio = msoTrue '縦横費を固定。
          .Width = tgtRange.MergeArea.Width
          .Height = tgtRange.MergeArea.Height
     End With

End Function

現在アクティブなセルに対して、画像選択ダイアログを開いて貼り付けるには、下記の関数を追加する。「Ctrl+Shift+V」とかショートカットを設定しておくと一発起動できて便利。

Sub 写真貼り付け()

'
' 写真貼り付け Macro
'
' Keyboard Shortcut: Ctrl+Shift+V

     Dim t As Range
     Set t = ActiveCell

     Dim fname As String
     fname = Application.GetOpenFilename ' ファイル選択ダイアログを開く。

     If fname = "False" Then fname = ""
          ' ※ GetOpenFilename は、ファイルが選択されなかった時には、
          '    文字列"False"を返す。

     Call 対象セルに画像を張り付ける(t, fname)

End Sub