學不完．教不停．用不盡

最近一直在做研習的講義，在 PowerPoint 的投影片中大多以文字方塊來呈現文字，想要把所有投影片中的文字提供給研習者以方便練習，這時才發現並沒有簡單的輸出方式。

例如，以下是人工智慧製圖的投影片，如果要方便使用者仿做或進行修改，就必須提供文字。而如果我把簡報另存為 PDF 檔，對使用者也是可以複製內容，只是必須一頁、一頁的單獨取字。

後來我求助 ChatGPT，它建議我採巨集指令，並且提供我 VBA 程式，一鍵即可完成。

【指令】如何使用VBA，一次取出PowerPoint簡報檔中所有投影片裡的文字？

你只要修改檔案路徑和檔名，並且在 VBA 環境中執行，即可一鍵取字。

Sub ExtractTextFromSlides()
    Dim pptApp As Object
    Dim pptPresentation As Object
    Dim pptSlide As Object
    Dim pptText As Object
    Dim outputPath As String
    Dim fileNum As Integer

    ' 设置 PowerPoint 应用程序
    Set pptApp = CreateObject("PowerPoint.Application")

    ' 打开演示文稿
    Set pptPresentation = pptApp.Presentations.Open("C:\Path\To\Your\Presentation.pptx")

    ' 指定输出文件的路径
    outputPath = "C:\Path\To\Your\Output\TextFile.txt"
    
    ' 打开输出文件以供写入
    fileNum = FreeFile
    Open outputPath For Output As #fileNum

    ' 遍历每个幻灯片
    For Each pptSlide In pptPresentation.Slides
        ' 遍历幻灯片上的每个文本框
        For Each pptText In pptSlide.Shapes
            If pptText.HasTextFrame Then
                If pptText.TextFrame.HasText Then
                    ' 将文本写入输出文件
                    Print #fileNum, pptText.TextFrame.TextRange.Text
                End If
            End If
        Next pptText
    Next pptSlide

    ' 关闭输出文件
    Close #fileNum

    ' 关闭 PowerPoint 应用程序
    pptApp.Quit

    ' 释放对象变量
    Set pptText = Nothing
    Set pptSlide = Nothing
    Set pptPresentation = Nothing
    Set pptApp = Nothing
End Sub

選取「插入／模組」，再貼上這些程式碼：

按下執行按鈕，即會輸出為一個文字檔，方便後續使用。