Excel VBA パワーポイントの情報をエクセルに書き出す

はじめに

過去のパワポデータの有効利用を目的にエクセルシートへの書き出しを行う

プロシジャーの説明

ExportAllPowerPointDataToExcelで実行
folderPathに対象フォルダパスを設定

作成したエクセルマクロ

注意．パワポの環境がない為に実際の動作は未確認。
このコードをベースにいろいろカスタマイズしないといけないです。

Sub ExportAllPowerPointDataToExcel()
    Dim pptApp As Object
    Dim pptPresentation As Object
    Dim pptSlide As Object
    Dim pptShape As Object
    Dim ws As Worksheet
    Dim i As Integer
    Dim row As Integer
    Dim folderPath As String
    Dim file As Object
    Dim fso As Object

    ' フォルダパスを指定
    folderPath = "C:\path\to\your\folder\"

    ' ファイルシステムオブジェクトを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Excelのアクティブシートを設定
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ws.Cells.Clear ' シートの内容をクリア
    row = 1

    ' PowerPointアプリケーションを起動
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
    End If
    On Error GoTo 0

    ' フォルダ内の各パワーポイントファイルをループ
    For Each file In fso.GetFolder(folderPath).Files
        If LCase(file.Name) Like "*.ppt*" Then
            ' パワーポイントのプレゼンテーションを開く
            Set pptPresentation = pptApp.Presentations.Open(file.Path)

            ' 各スライドをループ
            For Each pptSlide In pptPresentation.Slides
                ' 各スライドのテキストをエクセルに書き出す
                For Each pptShape In pptSlide.Shapes
                    If pptShape.HasTextFrame Then
                        If pptShape.TextFrame.HasText Then
                            ws.Cells(row, 1).Value = file.Name
                            ws.Cells(row, 2).Value = pptShape.TextFrame.TextRange.Text
                            row = row + 1
                        End If
                    End If
                Next pptShape
            Next pptSlide

            ' プレゼンテーションを閉じる
            pptPresentation.Close
        End If
    Next file

    ' PowerPointを終了
    pptApp.Quit

    ' オブジェクトを解放
    Set pptShape = Nothing
    Set pptSlide = Nothing
    Set pptPresentation = Nothing
    Set pptApp = Nothing
    Set fso = Nothing
End Sub