怎样批量提取 PPT 中多个文本框里的文字？

梦貘 2023-06-23

他山之石

前言：最近整理笔记，需要从PPT中批量提取所有问题，于是从知乎上搜到了这篇文章，十分有用，遂存档备用。

原文地址

首先考虑最简单的情况，如果你的 PPT 是严格按照模板的大纲来写的话，可以直接用 PowerPoint 自带的「另存为/导出」功能，将文本导出为「rtf 文件」：

导出的 rtf 文件如下（与 text 文件的区别在于，它还保留了字体、字号、颜色等信息）：

然后考虑复杂点的情况，如果你的 PPT 文件不是按照标准的模板来做的话，比如插入了很多自定义的文本框，这时就需要用到下面的方法了：

一、Windows 上从单页或多页 PPT 中提取所有文本框内的文字

主要利用 VBA 代码[1][2]实现

首先需要打开 PowerPoint 中的 Visual Basic 编辑器，并插入一个「模块」：

在新插入的模块的编辑器中输入以下代码，然后点击顶部菜单栏中的三角按钮来运行：

运行之后，就会在 PPT 同目录下生成与 PTT 文件同名的 .txt 文件，其中内容格式如下：

Slide: [页码编号]

Slide: [页码编号]

……

上面用到的 VBA 代码如下（也适用于 Mac）：

如果不想要导出全部幻灯片的文本，可以在代码里面修改页码范围，即把下面的代码 For i = 1 To num_slides 修改成你想要的范围（如第 4 页到第 8 页）： For i = 4 To 8

vb.net
Sub ExportText()
  Dim oPres As Presentation
  Dim oSlides As Slides
  Dim oSld As Slide         'Slide Object
  Dim oShp As Shape         'Shape Object
  Dim iFile As Integer      'File handle for output
  iFile = FreeFile          'Get a free file number
  Dim PathSep As String
  Dim FileNum As Integer
  Dim sTempString As String

  #If Mac Then
    PathSep = "/"
  #Else
    PathSep = "\"
  #End If

  Set oPres = ActivePresentation
  Set oSlides = oPres.Slides

  FileNum = FreeFile

  'Open output file
  ' NOTE:  errors here if file hasn't been saved
  'Open oPres.Path & PathSep & "AllText.txt" For Output As FileNum
  Open oPres.Path & PathSep & oPres.Name & ".txt" For Output As FileNum
  
  num_slides = ActivePresentation.Slides.Count

  For i = 1 To num_slides
    Set oSld = ActivePresentation.Slides(i)
    Print #iFile, "Slide:" & vbTab & CStr(oSld.SlideNumber)

    For Each oShp In oSld.Shapes
      'Check to see if shape has a text frame and text
      If oShp.HasTextFrame And oShp.TextFrame.HasText Then
        If oShp.Type = msoPlaceholder Then
            Select Case oShp.PlaceholderFormat.Type
                Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
                    Print #iFile, "标题：" & vbTab & oShp.TextFrame.TextRange
                Case Is = ppPlaceholderBody
                    Print #iFile, "正文：" & vbTab & oShp.TextFrame.TextRange
                Case Is = ppPlaceholderSubtitle
                    Print #iFile, "副标题：" & vbTab & oShp.TextFrame.TextRange
                Case Else
                    Print #iFile, "其他占位符：" & vbTab & oShp.TextFrame.TextRange
            End Select
        Else
            Print #iFile, vbTab & oShp.TextFrame.TextRange
        End If  ' msoPlaceholder
      Else  ' it doesn't have a textframe - it might be a group that contains text so:
        If oShp.Type = msoGroup Then
            sTempString = TextFromGroupShape(oShp)
            If Len(sTempString) > 0 Then
                Print #iFile, sTempString
            End If
        ElseIf oShp.Type = msoSmartArt Then
            sTempString = TextFromSmartArtNode(oShp.SmartArt.Nodes, 0)
            If Len(sTempString) > 0 Then
                Print #iFile, sTempString
            End If
        End If
      End If    ' Has text frame/Has text
    Next oShp
    
    Print #iFile, vbCrLf
    Next i
  Close #iFile

  'MsgBox "文件已创建在 '" & oPres.Path & PathSep & "AllText.txt'"
  MsgBox "文件已创建在 '" & oPres.Path & PathSep & oPres.Name & ".txt'"
End Sub

Function TextFromGroupShape(oSh As Shape) As String
' Returns the text from the shapes in a group
' and recursively, text within shapes within groups within groups etc.

    Dim oGpSh As Shape
    Dim sTempText As String

    If oSh.Type = msoGroup Then
        For Each oGpSh In oSh.GroupItems
            With oGpSh
                If .Type = msoGroup Then
                    sTempText = sTempText & TextFromGroupShape(oGpSh)
                Else
                    If .HasTextFrame Then
                        If .TextFrame.HasText Then
                            sTempText = sTempText & "(Gp:) " & .TextFrame.TextRange.Text & vbCrLf
                        End If
                    End If
                End If
            End With
        Next
    End If

    TextFromGroupShape = sTempText

End Function

Function TextFromSmartArtNode(oSh As SmartArtNodes, depth As Long) As String
' Returns the text from the shapes in a SmartArt shape recursively

    Dim sTempText As String
    For i = 1 To oSh.Count
        With oSh(i)
            If .TextFrame2.TextRange.Text <> "" Then
                If depth = 0 Then
                    sTempText = sTempText & "(SmartArt:)" & .TextFrame2.TextRange & vbCrLf
                Else
                    sTempText = sTempText & Space(depth * 4) & .TextFrame2.TextRange & vbCrLf
                End If
                sTempText = sTempText & TextFromSmartArtNode(.Nodes, depth + 1)
            End If
        End With
    Next i

    TextFromSmartArtNode = sTempText

End Function

【更新】

增加了批量处理多个文件的功能，现在会自动在所处理的 PPT 文件同目录下生成同名的 txt 文件，如处理 “C:\Users\Emrys\Desktop\demo.pptx” 后会生成 “C:\Users\Emrys\Desktop\demo.pptx.txt”。

注意：如果选择的 PPT 文件比较多/比较大，运行可能比较卡顿且耗时稍久，此时请耐心等待，不要频繁操作电脑。

vb.net
Sub ExportText()
  Dim oPres As Presentation
  Dim oSlides As Slides
  Dim oSld As Slide         'Slide Object
  Dim oShp As Shape         'Shape Object
  Dim iFile As Integer      'File handle for output
  iFile = FreeFile          'Get a free file number
  Dim PathSep As String
  Dim FileNum As Integer
  Dim sTempString As String
  Dim fd() As String

  #If Mac Then
    PathSep = "/"
  #Else
    PathSep = "\"
  #End If

  fd = Split(FileDialogOpen, vbLf)
  If Left(fd(0), 1) = "-" Then
    Debug.Print "Canceled"
    Exit Sub
  End If

  For n = LBound(fd) To UBound(fd)
    Set oPres = Presentations.Open(FileName:=fd(n), ReadOnly:=msoTrue, WithWindow:=msoTrue)
    Set oSlides = oPres.Slides

    FileNum = FreeFile

    'Open output file
    ' NOTE:  errors here if file hasn't been saved
    Open oPres.Path & PathSep & oPres.Name & ".txt" For Output As FileNum
    
    num_slides = oPres.Slides.Count

    For i = 1 To num_slides
      Set oSld = oPres.Slides(i)
      Print #iFile, "Slide:" & vbTab & CStr(oSld.SlideNumber)
      For Each oShp In oSld.Shapes
        'Check to see if shape has a text frame and text
        If oShp.HasTextFrame And oShp.TextFrame.HasText Then
          If oShp.Type = msoPlaceholder Then
            Select Case oShp.PlaceholderFormat.Type
              Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
                Print #iFile, "标题：" & vbTab & oShp.TextFrame.TextRange
              Case Is = ppPlaceholderBody
                Print #iFile, "正文：" & vbTab & oShp.TextFrame.TextRange
              Case Is = ppPlaceholderSubtitle
                Print #iFile, "副标题：" & vbTab & oShp.TextFrame.TextRange
              Case Else
                Print #iFile, "其他占位符：" & vbTab & oShp.TextFrame.TextRange
            End Select
          Else
            Print #iFile, vbTab & oShp.TextFrame.TextRange
          End If  ' msoPlaceholder
        Else  ' it doesn't have a textframe - it might be a group that contains text so:
          If oShp.Type = msoGroup Then
            sTempString = TextFromGroupShape(oShp)
            If Len(sTempString) > 0 Then
              Print #iFile, sTempString
            End If
          ElseIf oShp.Type = msoSmartArt Then
            sTempString = TextFromSmartArtNode(oShp.SmartArt.Nodes, 0)
            If Len(sTempString) > 0 Then
              Print #iFile, sTempString
            End If
          End If
        End If    ' Has text frame/Has text
      Next oShp
      
      Print #iFile, vbCrLf
    Next i
    Close #iFile
    oPres.Close
  Next n

  MsgBox "已处理 " & UBound(fd) - LBound(fd) + 1 & " 个文件"
End Sub

Function TextFromGroupShape(oSh As Shape) As String
' Returns the text from the shapes in a group
' and recursively, text within shapes within groups within groups etc.

  Dim oGpSh As Shape
  Dim sTempText As String

  If oSh.Type = msoGroup Then
    For Each oGpSh In oSh.GroupItems
      With oGpSh
        If .Type = msoGroup Then
          sTempText = sTempText & TextFromGroupShape(oGpSh)
        Else
          If .HasTextFrame Then
            If .TextFrame.HasText Then
              sTempText = sTempText & "(Gp:) " & .TextFrame.TextRange.Text & vbCrLf
            End If
          End If
        End If
      End With
    Next
  End If

  TextFromGroupShape = sTempText

NormalExit:
  Exit Function

Errorhandler:
  Resume Next

End Function


Function TextFromSmartArtNode(oSh As SmartArtNodes, depth As Long) As String
' Returns the text from the shapes in a SmartArt shape recursively

    Dim sTempText As String
    For i = 1 To oSh.Count
        With oSh(i)
            If .TextFrame2.TextRange.Text <> "" Then
                If depth = 0 Then
                    sTempText = sTempText & "(SmartArt:)" & .TextFrame2.TextRange & vbCrLf
                Else
                    sTempText = sTempText & Space(depth * 4) & .TextFrame2.TextRange & vbCrLf
                End If
                sTempText = sTempText & TextFromSmartArtNode(.Nodes, depth + 1)
            End If
        End With
    Next i

    TextFromSmartArtNode = sTempText

End Function


Function FileDialogOpen() As String

  #If Mac Then
    ' 默认路径
    mypath = MacScript("return (path to desktop folder) as String")

    sMacScript = "set applescript's text item delimiters to "","" " & vbNewLine & _
    "try " & vbNewLine & _
    "set theFiles to (choose file of type {""ppt"", ""pptx""}" & _
    "with prompt ""请选择要处理的一个或多个 PowerPoint 文档"" default location alias """ & _
    mypath & """ multiple selections allowed true)" & vbNewLine & _
    "set applescript's text item delimiters to """" " & vbNewLine & _
    "on error errStr number errorNumber" & vbNewLine & _
    "return errorNumber " & vbNewLine & _
    "end try " & vbNewLine & _
    "repeat with i from 1 to length of theFiles" & vbNewLine & _
    "if i = 1 then" & vbNewLine & _
    "set fpath to POSIX path of item i of theFiles" & vbNewLine & _
    "else" & vbNewLine & _
    "set fpath to fpath & """ & vbNewLine & _
    """ & POSIX path of item i of theFiles" & vbNewLine & _
    "end if" & vbNewLine & _
    "end repeat" & vbNewLine & _
    "return fpath"

    FileDialogOpen = MacScript(sMacScript)

  #Else
    With Application.FileDialog(msoFileDialogOpen)
      .AllowMultiSelect = True
      .Title = "请选择要处理的一个或多个 PowerPoint 文档"
      .Filters.Add "PowerPoint 文档", "*.ppt; *.pptx", 1
      If .Show = -1 Then
        FileDialogOpen = ""
        For i = 1 To .SelectedItems.Count
          If i = 1 Then
            FileDialogOpen = .SelectedItems.Item(i)
          Else
            FileDialogOpen = FileDialogOpen & vbLf & .SelectedItems.Item(i)
          End If
        Next
      Else
        FileDialogOpen = "-"
      End If
    End With

  #End If
End Function

二、Mac OS 上从单页或多页 PPT 中提取所有文本框内的文字

主要利用 AppleScript 脚本实现

首先打开想要提取文字的 PPT 文档，然后打开「脚本编辑器/Script Editor」app，在其中输入下图中的代码后，点击运行按钮：

运行之后，会弹窗询问需要提取文字的 PPT 页码范围，输入之后，就会在桌面上自动生成以该 PPT 文件名为前缀的 txt 文件，并打开它。txt 文件的内容为所选 PPT 页码范围内的所有文本框内容，默认格式为：

(Page ?) xxxxx -————————- yyyyyy -————————-

(Page ?) xxxx -————————-

其中 (Page ?) 表示下面的文本为第 ? 页的内容，-------------------------- 用于分隔不同文本框的文字。如果不想要这些信息，只要把代码中的相应文本（如第 3 行和第 8 行代码）改掉即可。

上面用到的 AppleScript 脚本如下：

applescript
set userLocale to user locale of (system info)
on pptGetAllText(page_from as integer, page_to as integer)
   set delimit to "--------------------------"
   tell application "Microsoft PowerPoint"
      activate
      set total_text to ""
      repeat with slideNumber from page_from to page_to
         set page_text to "(Page " & (slideNumber as text) & ")
"
         tell slide slideNumber of active presentation
            repeat with shapeNumber from 1 to count of shapes
               set shapeText to content of text range of text frame of shape shapeNumber
               if shapeText is not missing value then
                  set page_text to (page_text & shapeText & "
" & delimit & "
")
               end if
            end repeat
         end tell
         set total_text to total_text & page_text & "


"
      end repeat
   end tell
   return total_text
end pptGetAllText

on validateInt(str_number as text)
   try
      set N to str_number as integer
      return {0, N}
   on error number errorNumber
      return {-1, -1}
   end try
end validateInt

on validateInput(page_from_to as text, num_slides as integer)
   set {flag, page_from, page_to} to {-1, -1, -1}
   set oldDelims to my text item delimiters -- save the current delimiters
   set my text item delimiters to {"-", "~", "～"} -- the character to split on
   set num to (count of text items of page_from_to)
   if num = 1 then
      # single page
      set {flag1, page_from} to my validateInt(first text item of page_from_to)
      if flag1 = 0 and page_from > 0 and page_from ≤ num_slides then set {flag, page_to} to {0, page_from}
   else if num = 2 then
      # multiple pages
      set {flag1, page_from} to my validateInt(first text item of page_from_to)
      set {flag2, page_to} to my validateInt(second text item of page_from_to)
      if flag1 = 0 and flag2 = 0 and page_from > 0 and page_from ≤ num_slides and page_from ≤ page_to and page_to > 0 and page_to ≤ num_slides then set flag to 0
   end if
   set my text item delimiters to oldDelims -- just to be safe, restore the old delimiters
   return {flag, page_from, page_to}
end validateInput

tell application "Microsoft PowerPoint" -- version: 2019
   set ppt_name to name of active presentation
   set num_slides to count of slides of active presentation
   set cur_page to slide number of slide of view of active window
   if cur_page is missing value then
      set tips to ""
   else
      set tips to "
[当前页码为 " & cur_page & "]"
   end if
   if num_slides = 1 then
      set default_ans to "1"
   else
      set default_ans to "1-" & (num_slides as text)
   end if
   set page_from_to to the text returned of (display dialog "请输入要处理的 PPT 页码范围" & tips & ":" default answer default_ans with title "提取 PPT 文本框内容" with icon note)
   set {flag, page_from, page_to} to my validateInput(page_from_to, num_slides)
   
   repeat while flag ≠ 0
      set page_from_to to the text returned of (display dialog "请输入要处理的 PPT 页码范围
[请确保页码范围有效]:" default answer default_ans with title "提取 PPT 文本框内容" with icon caution)
      set {flag, page_from, page_to} to my validateInput(page_from_to, num_slides)
   end repeat
end tell

set content_to_write to pptGetAllText(page_from, page_to)
set filename to POSIX path of (((path to desktop folder) as text) & ppt_name & ".txt")
(*
tell application "TextEdit"
   activate
   set newDoc to (make new document with properties {text:(content_to_write as Unicode text)})
end tell
*)
do shell script "cat > " & filename & " << 'EOF'
" & content_to_write as Unicode text & "
'EOF'"

set file_path to filename as POSIX file
tell application "Finder" to open file file_path

参考

[^](#ref_1_0)Stack Overflow: Extracting all text from a powerpoint file in VBA https://stackoverflow.com/a/4675964
[^](#ref_20)Export Text to a text file, extract text from PowerPoint (Mac or PC) http://www.pptfaq.com/FAQ00274_Export_Text_to_a_text_file-_extract_text_from_PowerPoint-Mac_or_PC-.htm
后记：将PPT或者DOCX文件的拓展名改成ZIP，就能从中批量提取出视频、图片等媒体文件。