PowerPointVBAで複数の表や図形に一括で画像を配置する
PowerPointの図形に対して画像を配置するには、というご相談をいただきまして、興味があったので調べてみました。このブログを始めた頃はExcelVBAしかさわったことがなかったのですが、Accessにも手を広げ、書籍を書くのに勉強を重ねたこともあり、VBAへの知見もだいぶ広がりましたので、今ならPowerPointVBAも書けるのでは！？ と思ってチャレンジした次第です。
仕様
スライドの準備
このようなスライドがあるとします。スライドにはそれぞれ図形（表含む）が複数個配置してあります。VBAで使う図形の名前は、「ホーム」→「選択」→「オブジェクトの選択と表示」ウィンドウで設定できるので、対象の図形を「shape〇」という名前にしておきます。「shape」という文字は任意で、数字部分を見て1から順番に画像を配置していきます。数値が途切れると途中終了してしまうので、途切れない連番を付けてください。
複数スライド対応のため2枚目も用意。こんな感じ。
画像の準備
挿入する画像はこんな感じだとします。「pic[スライド番号]-[画像番号]」です。「pic」という文字は任意です。スライド1枚目用、2枚目用にそれぞれ8枚ずつわかりやすいように番号を入れて用意しました。
画像は、対象のPowerPointファイルと同じフォルダに「img」というフォルダを作ってそこに入れています。このあたりは後述のコードでお好きにカスタマイズしてください。
ぱくたそさんの画像ガチャでサンプル画像作らせてもらいました。いつもありがとうございます！
実行後
後述のコードを実行するとこのような結果になります。「shape〇」という順番で、画像を連番で配置していきます。対象が表だった場合は、1列埋めてから次の行へ移ります。画像は「pic1-8.jpg」まで用意してありましたが、画像を配置する対象の場所が7個しかなかったので、8個目は実行されません。
2枚目。今度のは配置する場所は余っていますが、「pic2-9.jpg」が存在しないのでこちらも入りません。
補足
調べてみた感じ、PowerPointでは画像の配置といえばこちらのAddPictureメソッドがセオリーな感じがしたのですが、これは画像を配置するShapeをその都度追加作成するもので、今回は既存のShapeに画像を設定したいとのことだったのでこちらは使いませんでした。
で、既存の表や図形に画像を挿入するには、とやってみたところ、図形の中に画像は、入らないっぽい…？ 挿入というより、画像右クリック→「塗りつぶし」→「図」の手順でやるやつ、これアレだ、背景画像だ！
というわけでどうも背景画像の設定という感じのコードになってしまったので、元々の図形の大きさを画像の比率に合わせてあげる必要があるかもしれません。
コード
メインのプロシージャは「sample」なので、これを実行してください。「setShape」と「hasImg」は連番の数の図形もしくは画像が存在するかチェックしている関数です。
Sub sample()
Dim pst As Presentation: Set pst = ActivePresentation 'アクティブプレゼンテーション
Dim imgPath As String '画像のパス用
Dim sld As Slide 'スライド用変数
For Each sld In pst.Slides 'スライドの数だけ繰り返す
Dim sldNum As Long: sldNum = sld.SlideNumber 'スライド番号を取得
Dim picNum As Long: picNum = 1 'スライドごとの画像番号を初期化
Dim shpNum As Long '図形番号用変数
For shpNum = 1 To 20 '1～20まで図形があるとして繰り返し
'図形の存在チェック
Dim shp As Variant
Set shp = setShape(sld, shpNum) '関数を使ってチェック
If shp Is Nothing Then '図形が存在しなかったら
GoTo skipSlide '次のスライドへ
End If
If shp.Type = msoTable Then '表だったら
'行列の変数セット
Dim rowCount As Long: rowCount = shp.Table.Rows.Count '行数取得
Dim columnCount As Long: columnCount = shp.Table.Columns.Count '列数取得
Dim row As Long, column As Long '繰り返し用変数
'繰り返しながら画像セット
For row = 1 To rowCount '行の繰り返し
For column = 1 To columnCount '列の繰り返し
'画像の存在チェック
imgPath = pst.Path & "\img\pic" & sldNum & "-" & picNum & ".jpg" '画像パスを作成
If Not hasImg(imgPath) Then '画像が存在しなかったら
GoTo skipSlide '次のスライドへ
End If
shp.Table.Cell(row, column).Shape.Fill.UserPicture imgPath '画像の設定
picNum = picNum + 1 '画像番号を次へ
Next column '次の列へ
Next row '次の行へ
Else '表じゃない図形だったら
'画像の存在チェック
imgPath = pst.Path & "\img\pic" & sldNum & "-" & picNum & ".jpg" '画像パスを作成
If Not hasImg(imgPath) Then '画像が存在しなかったら
GoTo skipSlide '次のスライドへ
End If
'画像セット
shp.Fill.UserPicture imgPath '画像の設定
picNum = picNum + 1 '画像番号を次へ
End If
Next shpNum '次の図形へ
skipSlide: '図形・画像が存在しなければここへ飛ぶ
Next sld '次のスライドへ
End Sub
Function setShape(ByVal sld As Slide, ByVal shpNum As Long) As Variant
'指定番号名の図形があるか判定する関数
On Error GoTo Err_Handler
Set setShape = sld.Shapes("shape" & shpNum) '指定番号名の図形をセット
Exit Function
Err_Handler: 'エラーならここへ飛ぶ
Set setShape = Nothing 'エラーの場合はNothingを返す
End Function
Function hasImg(ByVal imgPath As String) As Boolean
'指定番号の画像が存在するか判定する関数
Dim rtn As String
rtn = Dir(imgPath) '判定
If rtn <> "" Then '画像パスが存在していたら
hasImg = True 'Trueを返す
End If
End Function
コメントいっぱい入れておいたのでお好きに読み解いてカスタマイズしてお使いください！
作るのに参考にさせていただきました。いつもありがとうございます！
追記
すみません公開してから気づいたのですが、コレ画像が多いと、画像のファイル名を一個一個変更するのが超めんどくさいな…！ って思ってしまいました。なので、以下のようにimgフォルダの下にスライド番号のフォルダを作って、その中に入ってる画像ならファイル名不問にしました。拡張子も複数指定できます。
img
├ 1 – 〇〇.jpg, 〇〇.jpg, 〇〇.png…
├ 2 – 〇〇.jpg, 〇〇.jpg, 〇〇.png…
└ 3 – 〇〇.jpg, 〇〇.jpg, 〇〇.png…
フォルダ内の画像ファイルを名前順に取得して貼り付けるコードが以下です。
Sub sample2()
Dim pst As Presentation: Set pst = ActivePresentation 'アクティブプレゼンテーション
Dim sld As Slide 'スライド用変数
For Each sld In pst.Slides 'スライドの数だけ繰り返す
Dim sldNum As Long: sldNum = sld.SlideNumber 'スライド番号を取得
Dim picNum As Long: picNum = 1 'スライドごとの画像番号を初期化
'指定スライド用の画像をコレクションへ
Dim picList As Collection: Set picList = New Collection 'コレクション作成
Dim imgPath As String: imgPath = pst.Path & "\img\" & sldNum 'スライド番号を含めたフォルダのパス
Dim buff As String: buff = Dir(imgPath & "\*") 'フォルダ内を検索
Do While buff <> "" 'ファイルが存在していたら
If Right(buff, 4) = ".jpg" Or Right(buff, 4) = ".png" Then '拡張子がjpgまたはpngだったら
picList.Add imgPath & "\" & buff 'コレクションにフルパスを追加
End If
buff = Dir() '次のファイルへ
Loop
Dim picCount As Long: picCount = picList.Count 'コレクションの最大値を取得
If picCount = 0 Then '画像ファイルがなければ
GoTo skipSlide '次のスライドへ
End If
Dim shpNum As Long '図形番号用変数
For shpNum = 1 To 20 '1～20まで図形があるとして繰り返し
'図形の存在チェック
Dim shp As Variant
Set shp = setShape(sld, shpNum) '関数を使ってチェック
If shp Is Nothing Then '図形が存在しなかったら
GoTo skipSlide '次のスライドへ
End If
If shp.Type = msoTable Then '表だったら
'行列の変数セット
Dim rowCount As Long: rowCount = shp.Table.Rows.Count '行数取得
Dim columnCount As Long: columnCount = shp.Table.Columns.Count '列数取得
Dim row As Long, column As Long '繰り返し用変数
'繰り返しながら画像セット
For row = 1 To rowCount '行の繰り返し
For column = 1 To columnCount '列の繰り返し
'画像の存在チェック
If picNum > picCount Then '最大個数を超えたら
GoTo skipSlide '次のスライドへ
End If
shp.Table.Cell(row, column).Shape.Fill.UserPicture picList(picNum) '画像の設定
picNum = picNum + 1 '画像番号を次へ
Next column '次の列へ
Next row '次の行へ
Else '表じゃない図形だったら
'画像の存在チェック
If picNum > picCount Then '最大個数を超えたら
GoTo skipSlide '次のスライドへ
End If
'画像セット
shp.Fill.UserPicture picList(picNum) '画像の設定
picNum = picNum + 1 '画像番号を次へ
End If
Next shpNum '次の図形へ
skipSlide: '図形・画像が存在しなければここへ飛ぶ
Next sld '次のスライドへ
End Sub
Function setShape(ByVal sld As Slide, ByVal shpNum As Long) As Variant
'指定番号名の図形があるか判定する関数
On Error GoTo Err_Handler
Set setShape = sld.Shapes("shape" & shpNum) '指定番号名の図形をセット
Exit Function
Err_Handler: 'エラーならここへ飛ぶ
Set setShape = Nothing 'エラーの場合はNothingを返す
End Function
画像のファイル名なんでもいいのでこっちのほうが楽かもしれません！
コメントは承認制ですので、反映までしばらくお待ち下さい。（稀にスパムの誤判定にて届かないこともあるようですので、必要な際はお問い合わせからお願い致します。）