Sub CombinePPTFiles()  
'           複数のパワポファイルの合体　名前なし。

  Dim ppaAppli As New PowerPoint.Application  'パワポ関係
  Dim pppPresen1 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 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\takasu\TakasuDocuments\7program\ppt/work6"

  strPathAll = strPath1 & "\results\all.ppt"  '出来上がりのファイルの名前
                              ' ディレクトリresultsはあらかじめ作っておく
                              
  Set fs1 = New Scripting.FileSystemObject
  Set base1 = fs1.GetFolder(strPath1) '
  
  Set files1 = base1.Files    '中にあるファイルのリスト
  
  intPPTFile = 0  '最初のファイルと２個め以降を区別するため。
  
  For Each file1 In files1
    strFileName = file1.Name                        'ファイル名
    strFileExt = fs1.GetExtensionName(Path:=strFileName)  '属性
     
    If strFileExt = "ppt" Then    'パワポファイルの場合のみ
    
      strPathFile = strPath1 & "\" & strFileName  ' パス付で書く
                       
      If intPPTFile = 0 Then  '初回はファイルをコピー
      
        fs1.CopyFile Source:=strPathFile, Destination:=strPathAll, Overwritefiles:=True
        
        Set pppPptAll = ppaAppli.Presentations.Open(strPathAll) 'コピー先をあけておく

        intPPTFile = intPPTFile + 1  '初回終了
      
      Else    '２つめ以降のファイルなら追加していく
          
        Set pppPresen2 = ppaAppli.Presentations.Open(strPathFile)  '追加ファイルを開ける
    
        intSlides = pppPptAll.Slides.Count '現在のスライド数
        pppPptAll.Slides.InsertFromFile strPathFile, intSlides  '追加ファイルは最後に入れる

        pppPresen2.Close  '追加ファイルは閉じる
        Set pppPresen2 = Nothing
      End If   '初回vs２回め以降の処理終わり
    
    End If  'パワポファイル処理終わり

  Next  '次のファイルへ
      
  pppPptAll.Save
  pppPptAll.Close
  ppaAppli.Quit
  
  Set pppPptAll = Nothing
  Set ppaAppli = Nothing
  
End Sub