从VBA中的PowerPoint文件中提取所有文本

Posted 2023-02-19

【中文标题】从VBA中的PowerPoint文件中提取所有文本

【英文标题】：Extracting all text from a powerpoint file in VBA

【发布时间】：2011-06-08 04:30:18

【问题描述】：

我有大量的 powerpoint 文件，我想从中提取所有文本，然后将它们全部集中到一个大文本文件中。每个源 (PPT) 文件都有多个页面（幻灯片）。我不关心格式 - 只关心单词。

我可以通过 PPT 中的 ^A ^C 和记事本中的 ^V 手动处理文件；然后在 PPT 中向下翻页，并为 powerpoint 中的每张幻灯片重复。 （太糟糕了，我不能只做一个 ^A 来抓住一切......然后我可以使用 sendkey 来复制/粘贴）

但是这些 PPT 有数百个，幻灯片数量不同。

这似乎是一件很常见的事情，但我在任何地方都找不到示例。

有人有示例代码吗？

【参考方案1】：

这里有一些代码可以帮助您入门。这会将幻灯片中的所有文本转储到调试窗口。除了转储之外，它不会尝试格式化、分组或做任何事情。

Sub GetAllText()
Dim p As Presentation: Set p = ActivePresentation
Dim s As Slide
Dim sh As Shape
For Each s In p.Slides
    For Each sh In s.Shapes
        If sh.HasTextFrame Then
            If sh.TextFrame.HasText Then
                Debug.Print sh.TextFrame.TextRange.Text
            End If
        End If
    Next
Next
End Sub

【讨论】：

我会试一试，然后回来！

酷。请注意，调试窗口可以容纳的文本数量有限。不过，您可以将结果踢出到 .txt 或其他文件中。

还是有问题。 Set PPT = CreateObject("PowerPoint.Application") PPT.Visible = True PPT.Presentations.Open filename:=src, ReadOnly:=True Set p = PPT.ActivePresentation For Each s In p.Slides For Each sh In s.Shapes If sh.HasTextFrame Then If sh.TextFrame.HasText Then Print #1, sh.TextFrame.TextRange.Text End If End If Next If Next

Powerpoint 似乎打开了，但我看不到这些东西......当我只是复制/粘贴你的代码时它工作正常，但我正在处理数百个（可能是 1000 个）这些文件一次。不知道如何在后续的 cmets 中格式化这个东西。谢谢，tff

要查看调试窗口，您需要在 PowerPoint 中打开 VBE（Visual Basic 编辑器）。然后打开立即窗口（我相信是 Ctrl+G）。但是，如果您想查看被踢出的内容，您也可以使用MsgBox 而不是Debug.Print。我会在一个小的 PPT 上这样做，因为它会很快填满返回的消息框中的大部分屏幕。不过，您是从不同的软件中自动执行此操作吗？我问是因为您正在做Set PPT = CreateObject("PowerPoint.Application")，如果您在 PowerPoint 中使用 VBE，则不需要这样做。

【参考方案2】：

以下示例显示了根据上面给出的 Otaku 代码循环遍历文件列表的代码：

Sub test_click2()

Dim thePath As String
Dim src As String
Dim dst As String
Dim PPT As PowerPoint.Application
Dim p As PowerPoint.Presentation
Dim s As Slide
Dim sh As PowerPoint.Shape
Dim i As Integer
Dim f(10) As String

f(1) = "abc.pptx"
f(2) = "def.pptx"
f(3) = "ghi.pptx"

thePath = "C:\Work\Text parsing PPT\"

For i = 1 To 3
  src = thePath & f(i)
  dst = thePath & f(i) & ".txt"

  On Error Resume Next
  Kill dst
  Open dst For Output As #1
    Set PPT = CreateObject("PowerPoint.Application")
    PPT.Activate
    PPT.Visible = True
    'PPT.WindowState = ppWindowMinimized
    PPT.Presentations.Open filename:=src, ReadOnly:=True
    For Each s In PPT.ActivePresentation.Slides
        For Each sh In s.Shapes
            If sh.HasTextFrame Then
                If sh.TextFrame.HasText Then
                    Debug.Print sh.TextFrame.TextRange.Text
                End If
            End If
        Next
    Next
    PPT.ActivePresentation.Close
  Close #1
Next i
Set PPT = Nothing

End Sub

【讨论】：

非常努力。感谢您与社区分享您的最终解决方案，同时仍接受 otaku 的回答。