VBA フォルダの全画像をWord文書に挿入 AddPicture

今回やりたいこと

たくさんある画像ファイルを、Word文書に取り込みたい。
大きすぎる画像ファイルの場合は、文書の横幅に合わせて縮小したい。

でも画像は100以上あるから、とんでもなく面倒だ……
そうだ、Word VBAで自動化しよう。

大まかな方針

• すべてのJPGファイルを再帰的に取得する => Collectionに入れる
  • 文書の末尾に画像を取り込む
  • 文書の横幅より大きければ縮小する

コード

Option Explicit

Const S_フォルダパス = "C:\Temp" 'ここを変更

Public Sub 今回の処理()
	Dim sファイルパス
	For Each sファイルパス In 全JPGパスを取得(C_フォルダパス)
		Dim o図 As InlineShape
		Set o図 = 画像を文書末尾に挿入(sファイルパス)
		文書横幅に合わせて縮小 o図
		o図.LockAspectRatio = msoTrue '縦横比は固定しておく
	Next
End Sub

Public Function 全JPGパスを取得(sフォルダパス) As Collection
	Dim c As New Collection
	全JPGパスを再帰的に取得 _
		CreateObject("Scripting.FileSystemObject"), c, sフォルダパス
	Set 全JPGパスを取得 = c
End Function

Private Sub 全JPGパスを再帰的に取得(fso, c As Collection, sフォルダパス)
	Dim oフォルダ As Object
	Set oフォルダ = fso.GetFolder(sフォルダパス)
	Dim oファイル As Object
	For Each oファイル In oフォルダ.Files
		Dim s拡張子 As String
		s拡張子 = fso.GetExtensionName(oファイル.Path)
		Select Case UCase(s拡張子)
		Case "JPG", "JPEG"
			c.Add oファイル.Path
		End Select
	Next
	Dim o子フォルダ As Object
	For Each o子フォルダ In oフォルダ.SubFolders
		全JPGパスを再帰的に取得 fso, c, o子フォルダ.Path
	Next
End Sub

Private Function 画像を文書末尾に挿入(sファイルパス) As InlineShape
	Dim rg As Range
	Set rg = ActiveDocument.Bookmarks("\EndOfDoc").Range
	Set 画像を文書末尾に挿入 = rg.InlineShapes.AddPicture(sファイルパス)
End Function

Private Sub 文書横幅に合わせて縮小(o図 As InlineShape)
	Dim n版面幅 As Single
	n版面幅 = 版面幅を取得(o図)
	If o図.Width > n版面幅 Then
		o図.Width = n版面幅
		o図.Height = o図.Height * 版面幅を取得(o図) / o図.Width
	End If
End Sub

Private Function 版面幅を取得(o図 As InlineShape) As Single
	Dim nセクション番号 As Single
	nセクション番号 = o図.Range.Information(wdActiveEndSectionNumber)
	版面幅を取得 = _
		o図.Range.Parent.Sections(nセクション番号).PageSetup. _
		TextColmuns(1).Width
End Function