フォルダ内のPowerPointファイルのページ数を数える

フォルダ内にあるpptファイルのページ数を数えるExcelマクロです。Folderにフォルダパスを渡し、StartRangeに結果の挿入開始位置を渡します。StartRangeから下向きに、ファイル名とページ数を記録していき、最後に合計値を計算します。

Private Sub CountPPTFilePageInFolder(Folder As String, StartRange As Range)
    If FS.FolderExists(Folder) = False Then
        MsgBox Folder + " フォルダが見つかりません。"
        Exit Sub
    End If
    
    Dim Filename As String
    Dim Count As Integer
    Filename = Dir(FS.BuildPath(Folder, "\*.ppt*"), vbNormal)
    If Filename = "" Then
        MsgBox "PowerPointファイルが見つかりません"
        Exit Sub
    End If
    
    Dim R As Range
    Set R = StartRange
    
    ' PowerPointアプリを作成
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    
    Do While Filename <> ""
        ' PowerPointファイルを開く
        Dim pptFile As Object
        Set pptFile = pptApp.presentations.Open(FS.BuildPath(Folder, Filename), WithWindow:=msoFalse)
        ' ページ数を数える
        Count = pptFile.Slides.Count
        pptFile.Close
       
        R.Value = Filename
        R.Cells(1, 2).Value = Count
        
        Set R = R.Offset(1, 0)
        Filename = Dir()
    Loop
    
    ' 合計値
    Dim SumRange As Range
    Set SumRange = R.Offset(0, 1)
    SumRange.Formula = "=SUM(" & StartRange.Offset(0, 1).Address & ":" & SumRange.Offset(-1, 0).Address & ")"
    
    ' PowerPointアプリを終了
    pptApp.Quit
End Sub

呼び出し例。

Public Sub UpdatePPTFilePageCount()
    Dim Folder As String
    ' A1にフォルダパスを記述
    Folder = Range("A1").Text
    ' シートをクリア
    Me.Cells.Clear
    
    Range("A1").Value = Folder
    
    ' A2から結果を出力
    Dim R As Range
    Set R = Range("A2")
    
    ' PPTのページ数カウント
    CountPPTFilePageInFolder Folder, R
    
    MsgBox "完了!"
End Sub