パワーポイント 画像挿入 マクロ VBA
大量の画像をパワーポイントに貼付ける必要があり、"ppt 画像挿入 マクロ"でググると以下のサイトが見つかった。https://www.ka-net.org/blog/?p=8228これを少し編集し、タイトルにファイルパス、テキストとして"サンプル"を挿入するようにしてみた。画像はpngのみを対象としている。1つのスライドに1枚の画像が挿入される。-----ここからSub InsertImages()'指定したフォルダ内の画像ファイルを一括挿入 Dim prs As PowerPoint.Presentation Dim sld As PowerPoint.Slide Dim shp As PowerPoint.Shape Dim txt As PowerPoint.Shape Dim tmp As PowerPoint.PpViewType Dim fol As Object, f As Object Dim fol_path As String '開いているプレゼンテーションをprsに格納 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 For Each f In .GetFolder(fol_path).Files 'PNGファイルのみ処理 Select Case LCase(.GetExtensionName(f.Path)) Case "png" 'スライド追加 Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutChartAndText) sld.Select '画像挿入 Set shp = sld.Shapes.AddPicture(FileName:=f.Path, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=0, _ Top:=0) With shp .LockAspectRatio = True '縦横比を固定 .Select '画像サイズ変更 .Width = .Width * 0.85 .Height = .Height * 0.85 End With '画像をスライド中央に配置 With ActiveWindow.Selection.ShapeRange .Align msoAlignCenters, True .Align msoAlignMiddles, True End With End Select'スライドタイトルをファイルパスに変更 sld.Shapes(1).TextFrame.TextRange.Text = f.Path 'テキスト挿入 Set txt = sld.Shapes.AddTextbox( _ Orientation:=msoTextOrientationHorizontal, _ Left:=600, _ Top:=50, _ Width:=250, _ Height:=10) With txt .Name = "AddedTextBox" .TextFrame.TextRange = "サンプル" .TextEffect.FontSize = 20 End With Next End WithFin: ActiveWindow.ViewType = tmp 'ウィンドウの表示モードを元に戻すEnd Sub-----ここまでお役に立てば幸いです。にほんブログ村