読者です 読者をやめる 読者になる 読者になる

ゴミ溜め@技術系日常系雑文

主にWeb技術やそのほかつまづいたこととか引っかかって調べたこととかをまとめてます。

はてなダイアリーから引っ越しました。)

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

VBA Excel

備忘録として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