【Word VBA】画像とファイルパスを挿入するWordマクロ

お客様から、画像をファイルに自動的にWordファイルに挿入するマクロの開発のご依頼をいただきました。

数十のファイルを挿入すると、かなり手間です。

お客様からのご要望は、ファイルを並べ替えたり、ファイルの種類を特定したり、画像ファイル名の特定の部分だけを画像と共に挿入したりと、様々な要望がありました。また、そもそも画像ファイルにリンクさせるのかどうか、リンク画像を保存するのかどうかなどファイルの作成ルールにより処理も異なると思います。

そうです。実務では現場ごとに様々な処理が要求されます。

この記事では、画像ファイルのファイルパスと画像を挿入することだけを実行します。

このマクロでできること

現在開かれているWordファイルが保存されているフォルダ内にある画像のうち、jpg形式とgif形式のファイルを文書の末尾に挿入します。

ファイルへのリンクはしません。

以下のようにsample1.docxファイルが保存されているフォルダ内に3つの画像ファイルが保存されています。test1.jpg, test2.gif, test3.pngと保存形式が異なります。

図の挿入

sample1.docxを開いてこのマクロを実行します。

(マクロ実行前)

図の挿入

(マクロ実行後)

test3.pngは挿入されません。

図の挿入

マクロの解説

文書の末尾の特定方法

文書の末尾に挿入しています。場所の特定は、32行目で

myDoc.Bookmarks("\EndOfDoc").Range

としています。組み込みのブックマークで指定できます。

これ以外の記述では、少し冗長になりますが

myDoc.Range((myDoc.Range.End - 1, myDoc.Range.End - 1)

としても同じ箇所を指定できます。上記で -1 として、文書の末尾の段落記号の1つ手前を指定します。

画像の挿入方法

AddPicture メソッドを使います。

文書の末尾で、まず画像の挿入(33行目)の後にファイルパスの挿入(34行目)をしています。

でも、入力位置に注目してください。

ファイルパスが書かれて、その下に画像が入ります。

これは、画像挿入の挙動に癖があるからです。

文書末尾に画像を挿入したのですが、挿入した位置は画像の直前箇所のままなのです。

なので、同じ挿入位置にファイルパスの文字列を挿入すると、画像の直前になるのです。

画像のリンク方法

画像にリンクさせるならば、AddPicture メソッドの引数(LinkToFile:=True)でリンクを指定してください。

画像の種類の特定方法

28行目から32行目で画像の種類を特定しています。ここに拡張子を追加すれば画像の種類別の処理ができます。

マクロ


Sub 画像の挿入()

 Dim myFolderPath As String 'フォルダパス
 Dim myFileName As String 'ファイル名
 Dim myFilePath As String 'ファイルパス
 Dim myExtension As String '拡張子
 Dim myDoc As Document
 Dim FSO As Object
 
 '-------------------------------------------
 '前処理
 '-------------------------------------------
 Set myDoc = ActiveDocument
 Set FSO = CreateObject("Scripting.FileSystemObject")
 
 myFolderPath = myDoc.Path
  
 '-------------------------------------------
 '画像データの挿入
 '-------------------------------------------
 'フォルダ中の任意のファイルを検索
 myFileName = Dir(myFolderPath & "\", vbNormal)
 
 Do While myFileName <> ""
 
  myExtension = LCase(FSO.GetExtensionName(myFileName))
  
  Select Case myExtension
  
   Case "jpg", "gif"
    myFilePath = myFolderPath & "\" & myFileName
    With myDoc.Bookmarks("\EndOfDoc").Range
     .InlineShapes.AddPicture FileName:=myFilePath
     .InsertAfter Text:=vbCr & myFilePath & vbCr
    End With
    
   Case Else
   
  End Select
     
  myFileName = Dir()
  
 Loop
 
 '-------------------------------------------
 'オブジェクト変数の解放
 '-------------------------------------------
 Set FSO = Nothing
 Set myDoc = Nothing
 
End Sub

トップへ戻る