Sub ChangeFontPPT()  
'           File System Objectを使う。
'           複数のパワポファイルのフォント変更

  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 strFont As String    '変更後のフォント名
  
  Dim strPath1 As String    'パワポファイルが入っている場所
  Dim strPathFile As String  '各ファイルをパス付で書く。
  
  Dim strFileName As String  'ファイル名
  Dim strFileExt As String   '属性(pptかどうか）
  
  Dim intSlide As Integer      '処理中のスライド番号
  Dim intNumSlides As Integer  'ファイルのスライド枚数
  
  Dim slide1 As PowerPoint.Slide
  Dim shape1 As PowerPoint.Shape
  Dim range1 As TextRange

  strFont = "ＭＳ ゴシック"  '変更した後のフォント
  strPath1 = "  ここにディレクトリを書く　"

  Set fs1 = New Scripting.FileSystemObject
  Set base1 = fs1.GetFolder(strPath1) '
  
  Set files1 = base1.Files    '中にあるファイルのリスト
  
  Debug.Print " Start here  --------"
  For Each file1 In files1
    strFileName = file1.Name                        'ファイル名

    strFileExt = fs1.GetExtensionName(Path:=strFileName)  '属性
     
    If strFileExt = "ppt" Then    'パワポファイルの場合のみ
 
      strPathFile = strPath1 & "\" & strFileName  ' パス付で書く
      Set pppPresen1 = ppaAppli.Presentations.Open(strPathFile)
    
      intNumSlides = pppPresen1.Slides.Count  'ファイルのスライド数
      
      For intSlide = 1 To intNumSlides  '各スライドについて
    
        Set slide1 = pppPresen1.Slides(intSlide)  'スライドの指定
    
        For Each shape1 In slide1.Shapes    'Shape について
    
          If shape1.HasTextFrame = msoTrue Then  'テキスト枠があるかチェック
            intWrite = intWrite + 1
            Set range1 = shape1.TextFrame.TextRange
            range1.Font.NameFarEast = strFont  'Fontの変更のはず。
          End If '
        Next shape1
      Next intSlide
      
      pppPresen1.Save    'パワポファイルを保存
      pppPresen1.Close   'パワポファイルを閉じる
      Set pppPresen1 = Nothing
    End If  'パワポファイル処理終わり
  Next  '次のファイルへ
  
  ppaAppli.Quit  'パワポを閉じる
  Set ppaAppli = Nothing
  
End Sub