通过vba提取PPT中的文字

oduang · 发表于 2023-9-16 21:15:08

环境准备：仅限于office环境下，WPS需在安装vba模块

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

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
复制代码