怎么从PPT中提取出所有的文字内容

碎碎念

又到了新闻稿生成的时候了，作为计算机类的学生，当然是使用那高端的NLP生成式AI大模型来解决这个文字上的工作啦！将PPT中的所有文字扔到GPT中，由GPT生成新闻稿，自己进行微调，完美！不过问题来了，怎么复制PPT中的所有内容呢？不会吧不会吧？你不会还在一个个文本框复制粘贴吧？害其实我之前也是这样，不过搞着麻烦啊！如果PPT页数多，可能写文稿的时间都没有复制粘贴耗费的时间多（bushi），经过我在网上的搜索，在知乎上找到了一个很好用的方法：VBA脚本，下面将这个好方法记录并分享一下。

使用教程

准备好你的一个或多个PPT，将其放到某个路径下，点击PPT上方菜单栏中的开发工具，点开visual basic工具，如下图：

点开后，你会看到一个样式超级土的IDE（我真的感觉他很有XP的风格），在上面的菜单栏中选择插入-> 模块：

会出现一个写代码的位置，将下方内容复制到代码块中：

basic

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

保存模块后然后点击运行：

在弹出的文件选择窗口中选择你所需要的一个或者多个PPT文件，点击确定，会得到提示：“已处理（）个文件”：

现在你就可以在文件的同目录下找到一个同文件名并以txt结尾的文件啦！里面就是所有的PPT中的文本框内容：

这种方法无法提取到备注中的内容，但是备注的内容用正常方法就可以提取出来啦，比如创建讲义，可以自行上网搜索搭配使用。

又多了一个偷懒小妙招！

参考链接

引用站外地址，不保证站点的可用性和安全性

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

zhihu.com

每日一图