PowerPointVBAで表や図形の背景画像を一括で配置する

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

画像のファイル名なんでもいいのでこっちのほうが楽かもしれません!

公開日:2020/04/25

10件のコメント

  1. 加藤 より:

    初めまして。加藤と申します。
    パワーポイントの操作についてご相談したくコメントさせていただきます。

    『PowerPointVBAで複数の表や図形に一括で画像を配置する』
    この方法で、【図の挿入】形式で行うことは可能でしょうか?
    また、画像のサイズ(比率)を指定することは可能でしょうか?

    スライドマスターでプレースホルダーから図を複数配置し(No,1~No,5)、編集画面で1つ(No,1)に図の挿入を行うと、他の図(No,2~5)にも反映されるようにしたいです。
    当サイトからVBAコードを使用させていただいたのですが、
    ・図の挿入にならず図形に対して画像が配置されてしまった。
    ・プレースホルダーの形に対して、元画像の比率が反映されずストレッチされた画像になってしまった。
    上記2点を改善できればと思っております。

    当方、VBAいついては初心者でして、コードをコピーして実行するくらいしかできません。
    お手数をお掛け致しますが、何卒宜しくお願い致します。

    • *yuko より:

      加藤さん、はじめまして、コメントありがとうございます。

      このページに書いてあるコードは、「あらかじめ配置してある」「表や三角、四角などの”図形”」の「背景画像」として写真を設定しているので、まったく目的が異なり、参考にはならないのではないかと感じます。画像を挿入することと、図形の背景に画像を設定するのは別物です。

      ご希望のことは、プレースホルダーのアイコンをクリックして起動する「図の挿入」から画像を選んで配置(ここまで手動ですよね)したのち、他の図(No,2~5)にも反映とありますが、2~5のプレースホルダーに1と同じ画像を挿入したい、という意図で合っていますでしょうか?

      VBAの実行は手動で行っていただいたと思うのですが、「図の挿入を行ったら自動で動いてほしい」ということになると、「図の挿入」が行われたタイミングを捕まえてプロシージャを実行させる、というしかけが必要になります。不可能ではないとは思いますが、難易度の高い実装です。現実的には、プレースホルダーではNO.1枠のみ用意しておいて手動で画像を挿入したのち、「1の画像を2~5の位置へコピペする」内容のVBAを手動で実行するほうが早いのでは、という感想を持ちました。意図が正確に読み取れていなかったら申し訳ありません。

  2. タクト より:

    とても良いコンテンツです!本当にありがとうございます。

    上記の「追記VBAコード」入れて表紙をつけたら、マクロが起動しなくなってしましました。
    スライド2枚目から実行するには、VBAのどこに何を追加で入れれば良いのでしょうか?

    お手数ですがお手すきの際にご確認頂けますと幸いです。

    • *yuko より:

      タクトさん、コメントありがとうございます。表紙を入れても「マクロが起動しなくなる」ことはないと思うので、「起動するが何も起こらない」ので「起動しなくなった」と感じていらっしゃるのではないでしょうか?

      追記のほうのコードはimgフォルダの下にスライド番号のフォルダを作って、そこに入っている画像を読み込みます。スライドに表紙を挿入すると以降のスライド番号が+1されるので、元々あったフォルダの番号とズレてしまった、ということではないでしょうか? その場合、画像の入っているフォルダの番号を+1してスライドと合うようにしてみてください。

  3. タクト より:

    大変失礼いたしました。フォルダの番号変更したら解決できました。
    分かりやすいご説明ありがとうございます。

    この内容とても良すぎて追加で2点ほど質問させていただきたいです。
    ①「追記」のVBAプログラムでは、指定したフォルダ内にある拡張子が”.jpg”または”.png”の画像ファイルを順番に読み込んで、PowerPoint内の図形に設定しているかと思います。画像ファイルが読み込まれる順番はどのような規則でしょうか?半角英字だとA~、半角数字だと1~、で合っておりますでしょうか?

    ②GIFデータも貼り付けたいのですが、コードの内容はどのようになりますでしょうか?
    参考になるページなどご共有頂けますと幸いです。

    何卒よろしくお願いいたします。

    追伸
    YOUTUBEチャンネル登録させてもらいました!
    書籍もPPTのVBA内容のものがあれば是非購入させていただきたいです!

    • *yuko より:

      タクトさん、フィードバックありがとうございます。

      ①画像の順番はおおむねフォルダエクスプローラでファイル名順に並んだものと同じなはずですが、全く同じかは自信がないので、VBEツールバー→表示→イミディエイトウィンドウを表示していただいたのち、以下のコードを実行していただければ、どの順番で画像を取得しているか見ることができます。(2行目にパスを指定してください)

      Sub checkImg()
        Dim imgPath As String: imgPath = "画像フォルダのパス"
        Dim buff As String: buff = Dir(imgPath & "\*") 'フォルダ内を検索
        Do While buff <> "" 'ファイルが存在していたら
          If Right(buff, 4) = ".jpg" Or Right(buff, 4) = ".png" Then '拡張子がjpgまたはpngだったら
            Debug.Print buff 'イミディエイトウィンドウへ出力
          End If
          buff = Dir() '次のファイルへ
        Loop
      End Sub
      

      ②GIFは、本文のコードだと14行目、上のコードだと5行目を以下のようにしてください。

      If Right(buff, 4) = ".jpg" Or Right(buff, 4) = ".png" Or Right(buff, 4) = ".gif" Then '拡張子がjpgまたはpngまたはgifだったら
      

      動画や書籍へも関心を持っていただけて嬉しいです、ありがとうございます!

  4. タクト より:

    yukoさん

    丁寧なご回答ありがとうございます。
    フォルダエクスプローラでファイル名順に並んだものではないようでしたので確認させていただきます。

    また2に関してもありがとうございます。

    すみません。追加の質問なのですが、
    ご紹介いただいているVBAコードはMacOSでも使用可能でしょうか?
    もし、使用できない場合WindowsコードからMac用のコードに変更することって可能でしょうか?
    ツールなどございましたらご紹介いただけますと幸いです。

    お手数ですが何卒よろしくお願いいたします。

    • *yuko より:

      タクトさん、フィードバックありがとうございます。申し訳ないのですが私は仕事でもプライベートでもWin版のVBAしかさわったことがなくて、Mac版VBAの知見がまったくありません。Macを持っていないので動くかどうかもわからないのです。ご期待に添えずに大変申し訳ありません。

  5. タクト より:

    何度も本当にすみません。
    2023年3月10日 5:41 PMに「GIFデータも貼り付けたい」とのことでご連絡させていただいた件で追加でご質問させていただきたいです。ご教授いただいた記述を追加したことによって、GIFデータの取得はできたのですが、PowerPointに(画像データではなく、)GIFデータのまま貼り付ける事ができない状態です。これを解消するための方法をご存知でしたらご教示いただきたいです。

    • *yuko より:

      お返事遅れてしまって申し訳ありません。gifでも試してみましたが、jpgやpngと同じように図形の背景画像として問題なく設定できるように思えます。ご希望の形の想像がつかないのではっきりしたことが言えませんが、このページで紹介しているコードは「図形の背景に画像を設定」する内容なので、「画像の挿入」が目的であれば、別の方法となります。「PowerPoint VBA 画像の挿入」などで検索すれば情報がたくさんありますので、ご活用ください。


コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください

コメントは承認制ですので、反映までしばらくお待ち下さい。(稀にスパムの誤判定にて届かないこともあるようですので、必要な際はお問い合わせからお願い致します。)

YouTubeでQ&Aコンテンツを企画しています

運営しているYouTubeチャンネルで、ご相談やご質問を募集しています。動画のコメントやお問い合わせページからお気軽にご相談をお寄せください。