Sub CombinePPTFiles() '  ' 複数のパワポファイルの合体 名前あり Dim ppaAppli As New PowerPoint.Application 'パワポ関係 Dim pppPresen1 As PowerPoint.Presentation Dim pppPptAll As PowerPoint.Presentation Dim fs1 As Scripting.FileSystemObject 'ファイルシステム関係 Dim base1 As Scripting.Folder Dim files1 As Scripting.Files Dim file1 As Scripting.File Dim strPath1 As String 'パワポファイルが入っている場所 Dim strPathFile As String '各ファイルをパス付で書く Dim strPathAll As String '合体したファイル Dim strPathCopy As String '作業用ファイル 最後に消す Dim strFileName As String 'ファイル名 Dim strFileExt As String '属性(pptかどうか) Dim slide1 As PowerPoint.Slide Dim shape1 As PowerPoint.Shape Dim range1 As TextRange Dim intSlides As Integer '現在のファイルの枚数(増加していく) Dim intPPTFile As Integer 'PPTファイルの番号 strPath1 = "C:\Users\ (以下略)  場所を書く " strPathAll = strPath1 & "\results\all.ppt" '出来上がりのファイルの名前 ' フォルダ resultsはあらかじめ作っておく Set fs1 = New Scripting.FileSystemObject Set base1 = fs1.GetFolder(strPath1) ' Set files1 = base1.Files '中にあるファイルのリスト intPPTFile = 0 '最初のファイルと2個め以降を区別するため。 For Each file1 In files1 strFileName = file1.Name 'ファイル名 strFileExt = fs1.GetExtensionName(Path:=strFileName) '属性 If strFileExt = "ppt" Then 'パワポファイルの場合のみ strPathFile = strPath1 & "\" & strFileName ' パス付で書く strPathCopy = strPath1 & "\out" & strFileName 'ファイル名の冒頭にoutを入れておく。 fs1.CopyFile Source:=strPathFile, Destination:=strPathCopy, Overwritefiles:=True '作業用ファイルにコピーする。 Call PutStringPpt(strPathCopy, strFileName) ' outファイルに文字列を入れる Set pppPathCopy = ppaAppli.Presentations.Open(strPathCopy) '追加ファイルを開ける If intPPTFile = 0 Then '初回はファイルをコピー fs1.CopyFile Source:=strPathCopy, Destination:=strPathAll, Overwritefiles:=True Set pppPptAll = ppaAppli.Presentations.Open(strPathAll) 'コピー先をあけておく intPPTFile = intPPTFile + 1 '初回終了 Else '2つめ以降のファイルなら追加していく intSlides = pppPptAll.Slides.Count '現在のスライド数 pppPptAll.Slides.InsertFromFile strPathCopy, intSlides '追加ファイルは最後に入れる End If '初回vs2回め以降の処理終わり pppPathCopy.Close '追加ファイルは閉じる fs1.DeleteFile filespec:=strPathCopy, Force:=True '作業ファイルを消す End If 'パワポファイル処理終わり Next '次のファイルへ pppPptAll.Save pppPptAll.Close ppaAppli.Quit Set pppPathCopy = Nothing Set pppPptAll = Nothing Set ppaAppli = Nothing Set fs1 = Nothing End Sub Sub PutStringPpt(ByVal strPath As String, ByVal strInsert As String) ' パワーポイントファイルの各シートに文字列とページ番号を入れる Dim ppaAppli As New PowerPoint.Application Dim pppPresen1 As PowerPoint.Presentation Dim slide1 As PowerPoint.Slide Dim shpTextBox As PowerPoint.Shape, shpTextBox2 As PowerPoint.Shape Dim intNumSlides As Integer Dim intSlide As Integer Set pppPresen1 = ppaAppli.Presentations.Open(strPath) 'ファイルを開ける intNumSlides = pppPresen1.Slides.Count '現在のスライド数 For intSlide = 1 To intNumSlides 'スライド番号 Set slide1 = pppPresen1.Slides(intSlide) 'スライド番号に対応するスライド Set shpTextBox = slide1.Shapes.AddTextbox _ (Orientation:=msoTextOrientationHorizontal, _ Left:=500, Top:=0, Width:=220, Height:=30) With shpTextBox.TextFrame.TextRange.Font .Size = 16 'フォントサイズ .Name = "MS 明朝" 'フォントの種類 End With shpTextBox.TextFrame.TextRange.Text = strInsert '語句をスライドに入れる。 Set shpTextBox2 = slide1.Shapes.AddTextbox _ (Orientation:=msoTextOrientationHorizontal, _ Left:=500, Top:=20, Width:=220, Height:=50) With shpTextBox2.TextFrame.TextRange.Font .Size = 16 'フォントサイズ .Name = "MS 明朝" 'フォントの種類 End With shpTextBox2.TextFrame.TextRange.Text = "page = " & intSlide ' ページ番号を書き入れる Next intSlide '次のスライド番号 pppPresen1.Save pppPresen1.Close Set pppPresen1 = Nothing End Sub