通过vba提取PPT中的文字

环境准备

仅限于office环境下，WPS需安装vba模块

提取步骤

打开PPT文件后，使用快捷键按ALT+F11（部分笔记本FN+ALT+F11）打开VBA编辑器

2.在菜单栏中选择“插入”→“模块”，添加一个模块

3.在菜单栏中选择“工具”→“引用”，寻找“Microsoft Word X.0 Object Library”（其中X与OFFICE版本有关，不唯一），选中并确定

4.在模块窗口插入下列代码

Sub 提取文字()
On Error Resume Next
Dim temp As New Word.Document, tmpShape As Shape, tmpSlide As Slide
For Each tmpSlide In ActivePresentation.Slides
For Each tmpShape In tmpSlide.Shapes
temp.Range().Text = temp.Range() + tmpShape.TextFrame.TextRange.Text
Next tmpShape
Next tmpSlide
temp.Application.Visible = True
End Sub

5.使用快捷键F5（部分笔记本FN+F5）或菜单栏选择“运行”→“运行子过程/用户窗体”运行代码
6.过一段时间后（取决于电脑配置及文件大小），电脑会自动打开包含提取文字的word，另存为即可

代码补充

下述代码可在PPT文件所在位置生成包含提取文字的txt文件

Public Sub Main()
    Dim temp As String, tmpShape As Shape, tmpSlide As Slide
    Dim pptPageCount As Integer, MyFName As String
    pptPageCount = ActivePresentation.Slides.Count
    For j = 1 To pptPageCount
            k = ActivePresentation.Slides(j).Shapes.Count
            For l = 1 To k
                On Error Resume Next
                    If ActivePresentation.Slides(j).Shapes(l).TextFrame.TextRange.Text <> "" Then
                        temp = temp + ActivePresentation.Slides(j).Shapes(l).TextFrame.TextRange.Text + Chr(10)
                    End If
                On Error GoTo 0
            Next l
    Next j
    MyFName = ActivePresentation.Path & "\" & Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 5) & ".txt"  '确定新建的txt文件的路径
    Call TextSave(MyFName, temp)
End Sub
Public Function TextSave(ByVal fileName As String, ByVal content As String)
    Set fso = CreateObject("Scripting.FileSystemObject") '创建文件需要使用Scripting.FileSystemObject对象
    Set myTxt = fso.CreateTextFile(fileName:=fileName, OverWrite:=True) '使用CreateTextFile创建文件
    myTxt.Write content '使用Write方法写入sheet名，然后插入一个换行符
    myTxt.Close
    Set myTxt = Nothing
End Function