パワーポイントに連続写真張り付け

on 11月 19, 2020

プレゼンの準備で、パワーポイントに写真を貼り付ける必要がある。１スライドに１枚貼り付けたいけど、スライドの真ん中に合わせたり拡大縮小とか大変で、しかも数が多いから自動でやってほしい。パワーポイントにもVBAが使える！

以下のサイトを参考にさせていただきました！先人のお知恵に感謝。
https://plaza.rakuten.co.jp/takupin/diary/201801260001/

PNGファイルが大量にあると仮定する。そして、それらの名前を貼り付けしたい順番に数字の名前とする。1.png、2.pngという感じ。もしJPGなら、コードをJPGに変更する。

Option Explicit
 
Public Sub InsertImages()

  Dim prs As PowerPoint.Presentation
  Dim sld As PowerPoint.Slide
  Dim shp As PowerPoint.Shape
  Dim tmp As PowerPoint.PpViewType
  Dim fol As Object, f As Object
  Dim fol_path As String
  Dim page
    
  page = InputBox("ページを入力してください")
  Set prs = ActivePresentation
  If SlideShowWindows.Count > 0 Then prs.SlideShowWindow.View.Exit

  With ActiveWindow
    tmp = .ViewType 
    .ViewType = ppViewSlide
  End With
   
  Set fol = CreateObject("Shell.Application").BrowseForFolder(0, "画像フォルダ選択", &H10, 0)
  If fol Is Nothing Then GoTo Fin
  fol_path = fol.Self.Path
   
  With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(fol_path) Then GoTo Fin
    
 Dim i
 For i = 1 To page
    
 Select Case LCase(.GetExtensionName(fol_path + "\" + CStr(i) + ".png"))
      
Case "png"
Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutBlank)
sld.Select
Set shp = sld.Shapes.AddPicture(FileName:=fol_path + "\" + CStr(i) + ".png", _
                                          LinkToFile:=False, _
                                          SaveWithDocument:=True, _
                                          Left:=0, _
                                          Top:=0)
With shp
.LockAspectRatio = True 
             
If .Width > .Height Then
.Width = prs.PageSetup.SlideWidth
Else
.Height = prs.PageSetup.SlideHeight
End If
             
.Select
End With
           
With ActiveWindow.Selection.ShapeRange
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With
End Select
Next
End With
Fin:
  ActiveWindow.ViewType = tmp 
End Sub

Categories:

VBA

category