ppt提取文字到word的代码(多种代码可选)

步骤有空再写

一、步骤

1. 开启ppt中开发工具(如果选项卡中显示就跳过)
   点击文件——更多——选项——自定义功能区——勾选开发工具
   
   
2. 按步骤进入，填入代码，代码在下一节。

开发者工具——查看代码——工具——引用。

找到Microsoft Word 开头的选项，勾选，确定。

插入——模块。在弹出的窗口填入代码，最后在插入选项卡下面找到绿色三角，点击即可运行代码。

二、代码

根据需要选其中一种就行。

1.提取文字到指定的文档，没有则新建。不能提取表格文字

Sub ExtractTextToWordDoc()Dim objPresentation As PresentationDim objSlide As SlideDim objShape As ShapeDim objTextFrame As TextFrameDim objTextRange As TextRangeDim strOutput As StringDim objWord As ObjectDim objDoc As ObjectSet objPresentation = ActivePresentationSet objWord = CreateObject("Word.Application")Set objDoc = objWord.Documents.AddFor Each objSlide In objPresentation.SlidesFor Each objShape In objSlide.ShapesIf objShape.HasTextFrame ThenSet objTextFrame = objShape.TextFrameSet objTextRange = objTextFrame.TextRangestrOutput = strOutput & objTextRange.Text & vbCrLfEnd IfNextNextobjDoc.Range.InsertAfter strOutputobjDoc.SaveAs "C:\Output.docx"objDoc.CloseobjWord.QuitMsgBox "文本提取已完成！"
End Sub

2.会到开一个新文档，不能提取表格文字

Sub ExtractText()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim wordApp As Object
Dim wordDoc As Object
Dim text As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Add()
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.HasTextFrame Then
text = pptShape.TextFrame.TextRange.text
wordDoc.Range.InsertAfter text
End If
Next pptShape
Next pptSlide
End Sub

3.会到开一个新文档，能提取表格文字，但表格中的文字会乱。

Sub ExtractText()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptTable As Table
Dim wordApp As Object
Dim wordDoc As Object
Dim text As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Add()
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.HasTable Then ' 检查pptShape是否是Table
Set pptTable = pptShape.Table ' 将pptShape强制转换为表格对象
For i = 1 To pptTable.Rows.Count
For j = 1 To pptTable.Columns.Count
text = pptTable.Cell(i, j).Shape.TextFrame.TextRange.text
wordDoc.Range.InsertAfter text
wordDoc.Range.InsertAfter " " ' 用空格分隔每个单元格中的文字
Next j
Next i
ElseIf pptShape.HasTextFrame Then
text = pptShape.TextFrame.TextRange.text
wordDoc.Range.InsertAfter text
End If
Next pptShape
Next pptSlide
End Sub

4.文字也能提取，但我运行后显示错误

一下代码可以逐一尝试，但不保证可以顺利运行，我的报错如图。这些方法也是搜来的，我也不懂vbs。如果有懂得的大佬可以说说，感谢😋

1. 第一种

Sub ExtractText()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptTable As Table
Dim wordApp As Object
Dim wordDoc As Object
Dim text As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Add()
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.HasTable Then
Set pptTable = pptShape.Table
For i = 1 To pptTable.Rows.Count
For j = 1 To pptTable.Columns.Count
text = pptTable.Cell(i, j).Shape.TextFrame.TextRange.Text
wordDoc.Tables.Add wordDoc.Range, 1, 1 ' 在Word文档中插入一个表格
wordDoc.Tables(1).Cell(i, j).Range.Text = text ' 将单元格中的文字插入到新表格中
Next j
Next i
ElseIf pptShape.HasTextFrame Then
text = pptShape.TextFrame.TextRange.Text
wordDoc.Range.InsertAfter text
End If
Next pptShape
Next pptSlide
End Sub

2. 第二种

Sub ExtractText()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptTable As Table
Dim wordApp As Object
Dim wordDoc As Object
Dim text As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Add()
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.HasTable Then
Set pptTable = pptShape.Table
Dim new_table As Table
Set new_table = wordDoc.Tables.Add(wordDoc.Range, pptTable.Rows.Count, pptTable.Columns.Count) ' 在 Word 文档中添加新表格
For i = 1 To pptTable.Rows.Count
For j = 1 To pptTable.Columns.Count
text = pptTable.Cell(i, j).Shape.TextFrame.TextRange.Text
new_table.Cell(i, j).Range.Text = text ' 将单元格中的文字插入到新表格中
Next j
Next i
ElseIf pptShape.HasTextFrame Then
text = pptShape.TextFrame.TextRange.Text
wordDoc.Range.InsertAfter text
End If
Next pptShape
Next pptSlide
End Sub

3. 第三种

Sub ExtractText()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptTable As Table
Dim wordApp As Object
Dim wordDoc As Object
Dim text As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Add()
For Each pptSlide In ActivePresentation.SlidesFor Each pptShape In pptSlide.ShapesIf pptShape.HasTable ThenSet pptTable = pptShape.TableDim new_table As TableSet new_table = wordDoc.Tables.Add(wordDoc.Range(), pptTable.Rows.Count, pptTable.Columns.Count)For Each row In pptTable.RowsFor Each column In pptTable.Columnstext = pptTable.Cell(row.Index, column.Index).Shape.TextFrame.TextRange.Textnew_table.Cell(row.Index, column.Index).Range!.Text = textNext columnNext rowElseIf pptShape.HasTextFrame Thentext = pptShape.TextFrame.TextRange.TextwordDoc.Range.InsertAfter(text)End IfNext pptShape
Next pptSlide
End Sub

4. 第四种

Sub ExtractText()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptTable As Table
Dim wordApp As Object
Dim wordDoc As Object
Dim text As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Add()
For Each pptSlide In ActivePresentation.SlidesFor Each pptShape In pptSlide.ShapesIf pptShape.HasTable ThenSet pptTable = pptShape.TableDim new_table As TableSet new_table = wordDoc.Tables.Add(wordDoc.Range(), pptTable.Rows.Count, pptTable.Columns.Count)For Each row In pptTable.RowsFor Each column In pptTable.Columnstext = pptTable.Cell(row.Index, column.Index).Shape.TextFrame.TextRange.Textnew_table.Rows(row.Index).Cells(column.Index).Range.Text = textNext columnNext rowElseIf pptShape.HasTextFrame Thentext = pptShape.TextFrame.TextRange.TextwordDoc.Range.InsertAfter textEnd IfNext pptShape
Next pptSlide
End Sub

本文来自互联网用户投稿，文章观点仅代表作者本人，不代表本站立场，不承担相关法律责任。如若转载，请注明出处。 如若内容造成侵权/违法违规/事实不符，请点击【内容举报】进行投诉反馈！