こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

パワポに大量の画像を自動で貼り付けたいです

100店舗の店舗案内を、1店舗1スライドのパワポで作ります。既に、店舗名、店舗コード、住所、電話番号等のデータはテキストでスライド毎に入力済みで、あとは、枠内に店舗外観の写真を挿入するのみの状態で、写真は別フォルダに保存済みです。
そこで質問ですが、1枚づつ写真をコピペではなく、100枚一括で挿入できないでしょうか?例えば、excelのvlookupのような感じで、既に記入されている店舗コードと同じファイル名の店舗画像を自動で引っ張ってきて、そのスライドの枠に貼り付けるような事が出来れば良いなと考えております。
なお、全部excelで作ってexcelをパワポに貼り付ける事ではなく、あくまでもパワポで作りたいです。良い方法があればお教えください。よろしくお願いいたします。

投稿日時 - 2017-09-24 01:49:36

QNo.9378043

困ってます

質問者が選んだベストアンサー

あらためて、#1 です。
あまり検証していませんが――
貼り付ける画像は、長辺が300(point)になるようにサイズ調整しています。

Sub Test3() '図形の塗りつぶし効果_アスペクト保持
 Dim FPath As String, i As Integer, nm As String, Pic As Object
 FPath = "C:\aaaa\bbbb\"
 For i = 1 To ActivePresentation.Slides.Count
  nm = ActivePresentation.Slides(i).Shapes(1).TextFrame.TextRange.Text
  '写真の元サイズ取得と図形サイズ変更
  Set Pic = LoadPicture(FPath & nm & ".jpg")
  With ActivePresentation.Slides(i).Shapes(6)
   Select Case Pic.Height
    Case Is <= Pic.Width
     .Width = 300
     .Height = 300 * (Pic.Height / Pic.Width)
    Case Else
     .Height = 300
     .Width = 300 * (Pic.Width / Pic.Height)
   End Select
   .Fill.Visible = msoTrue
   .Fill.UserPicture FPath & nm & ".jpg"
  End With
  Set Pic = Nothing
 Next
End Sub

Sub Test4() '定位置へ挿入_アスペクト保持
 Dim FPath As String, i As Integer, nm As String
 Dim Pic As Object, WD As Single, HT As Single
 FPath = "C:\aaaa\bbbb\"
 For i = 1 To ActivePresentation.Slides.Count
  ActiveWindow.View.GotoSlide i
  nm = ActivePresentation.Slides(i).Shapes(1).TextFrame _
    .TextRange.Text
  '写真の元サイズ取得~貼付けサイズ算出
  Set Pic = LoadPicture(FPath & nm & ".jpg")
  Select Case Pic.Height
   Case Is <= Pic.Width
    WD = 300
    HT = Pic.Height * (300 / Pic.Width)
   Case Else
    HT = 300
    WD = Pic.Width * (300 / Pic.Height)
  End Select
  Set Pic = Nothing
  '写真貼付け
  ActiveWindow.Selection.SlideRange.Shapes.AddPicture _
   (FileName:=FPath & nm & ".jpg", LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=350, Top:=200, Width:=WD, Height:=HT).Select
 Next
 ActiveWindow.View.GotoSlide 1
End Sub

投稿日時 - 2017-09-25 09:06:19

お礼

平日にも関わらず早い返信いただき感謝です。おかげさまで求めていた処理が簡単に実行でき、なおかつ次回実施時の財産になり、私の勉強にもなりました。大変ありがとうございました。

投稿日時 - 2017-09-25 19:56:41

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.2

#1 です。
>Shapes(6)がピクチャデータです。
 "枠"が"ピクチャデータ"とは、どういう状況なのでしょう。
 そのへんがわかりませんので、とりあえず2ケース考えてみました。

Test1:枠(Picture6)がテキストボックスまたは図形(四角)と仮定し、その
    塗りつぶし効果で写真を指定する例。
Test2:Picture6を無視し、指定位置に指定サイズで写真を挿入する例。

Sub Test1()
 Dim FPath As String, nm As String, i As Integer
 FPath = "C:\aaaa\bbbb\" '実際の写真フォルダのパス + \ に。
 For i = 1 To ActivePresentation.Slides.Count
  nm = ActivePresentation.Slides(i).Shapes(1).TextFrame.TextRange.Text
  With ActivePresentation.Slides(i).Shapes(6)
   .Fill.Visible = msoTrue
   .Fill.UserPicture FPath & nm & ".jpg"
  End With
 Next
End Sub

Sub Test2()
 Dim FPath As String, nm As String, i As Integer
 FPath = "C:\aaaa\bbbb\" '実際の写真フォルダのパス + \ に。
 For i = 1 To ActivePresentation.Slides.Count
  ActiveWindow.View.GotoSlide i
  nm = ActivePresentation.Slides(i).Shapes(1).TextFrame.TextRange.Text
  ActiveWindow.Selection.SlideRange.Shapes.AddPicture _
    (FileName:=FPath & nm & ".jpg", LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=400, Top:=200, Width:=240, Height:=180).Select
 Next
 ActiveWindow.View.GotoSlide 1
End Sub

投稿日時 - 2017-09-24 18:34:44

補足

ありがとうございます。Test1,Test2ともに私の求めていたものです。

ただ、もう一つだけお願いします。これは私が情報を伝えていなかった事ですので大変申し訳ございませんが、店舗外観の写真の元データが縦横比固定でないため、上記を実行すると縦横比が変わってしまいます。元データの比率をそのまま挿入することは可能でしょうか?

投稿日時 - 2017-09-24 20:32:24

ANo.1

マクロを使用しないとできないと思いますが、その場合でも、以下のような
情報が不足しています。

>店舗名、店舗コード、住所、電話番号等のデータはスライド毎に入力済み。
>枠内に店舗外観の写真を挿入する。

1.各データは、個々のテキストボックスに入力されているのでしょうか。
 1つのテキストボックスに行分けして入力されているのでしょうか。

2.店舗コードの入った枠と写真挿入用の枠の名前や位置、サイズは、全ページ
 共通なのでしょうか。
  ※プレースホルダまたはテキストボックスの名前を指定して、コード名を
   取得したり写真を挿入する必要がありますので、全スライドがひとつの
   様式をコピーして編集されたものであることが望ましいのですが‥‥

投稿日時 - 2017-09-24 15:32:07

補足

早速ご回答いただきありがとうございます。ご質問の回答としては、
1.個々のテキストボックスに入力しています。
2.全ページ共通です。

実は勉強したてで表現が合っているかわかりませんが、1スライドにはShapes(1) ~Shapes(6) があり、(1)~(5)がテキストデータで入力は1行のみ、(6)がピクチャデータです。シェイプの位置等はすべてのスライド共通です。

・Shapes(1) TextBox 3 店舗コード
・Shapes(2) TextBox 4 店舗名
・Shapes(3) TextBox 5 住所
・Shapes(4) TextBox 6 電話番号
・Shapes(5) TextBox 7 コメント欄
・Shapes(6) Picture 9 店舗外観の写真

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

投稿日時 - 2017-09-24 16:59:26

あなたにオススメの質問