③powerpointのスライドを印刷して参加者に配布する際に用紙数が多くなって困ります
全自動のマクロを作りましたこちらに保管しておりますパソコンでこんなことができますパソコンでこんなことができます PPTX,PDF,VIDEOclinic.mond.jpDim imageFolderDim ttxSub PPTXスライドをwordに挿入します()' 画像挿入マクロMain パワーポイントでエクスポートされたスライド画像を取り込むマクロです'ｐｐｔｘとこのＷＯＲＤを同じところに置いてください'このマクロをWORDで実行してください'音声合成のため 参照設定：Microsoft Excel 16.0 Object Library' ttx = True imageFolder = "images" Call pptx2Image 'PPTXエクスポート Call insertAllImage '挿入 speak ("完了しました")End SubSub insertAllImage()'speak ("WORDにpowerpointのエクスポートされた画像を挿入します")Dim objFso As ObjectSet objFso = CreateObject("Scripting.FileSystemObject")Dim strPath As String'ドキュイメントのパスstrPath = ThisDocument.Path'画像ファイル数を見つけるn = 0Dim obj As ObjectFor Each obj In objFso.getfolder(strPath & "\" & imageFolder).Files If InStr(obj.Name, ".png") <> 0 Then n = n + 1Next objSet objFso = Nothingspeak ("画像が" & n & "個見つかりました。挿入します")'挿入For k = 1 To n cname = strPath & "\" & imageFolder & "\" & Trim(k) & ".png" Selection.InlineShapes.AddPicture FileName:=cname, LinkToFile:=False, SaveWithDocument:=TrueNextEnd Sub'参照設定：Microsoft Excel 16.0 Object LibrarySub speak(line) If ttx = True Then Dim ExObj As Object Set ExObj = CreateObject("Excel.Application") ExObj.Speech.speak line ExObj.Quit Else MsgBox line End IfEnd SubSub pptx2Image()'wordと同じ場所にあるPPTXを探して、画像にエクスポートします Dim objFso As Object Set objFso = CreateObject("Scripting.FileSystemObject") Dim strPath As String strPath = ThisDocument.Path Dim obj As Object For Each obj In objFso.getfolder(strPath).Files If InStr(obj.Name, ".pptx") <> 0 Then pptxname = obj.Name Exit For End If Next obj Set objFso = Nothing speak (pptxname & " powerpointを画像にエクスポートします") Dim p, f, s With CreateObject("PowerPoint.Application") Set p = .Presentations.Open(strPath & "\" & pptxname, -1, 0, 0) With CreateObject("Scripting.FileSystemObject") f = .BuildPath(strPath, imageFolder) If Not .FolderExists(f) Then .CreateFolder f For Each s In p.Slides s.Export .BuildPath(f, s.SlideNumber & ".png"), "png" Next End With .Quit End WithEnd Sub
