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

步骤有空再写

一、步骤

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

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

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

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

二、代码

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

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

Sub ExtractTextToWordDoc()
  Dim objPresentation As Presentation
  Dim objSlide As Slide
  Dim objShape As Shape
  Dim objTextFrame As TextFrame
  Dim objTextRange As TextRange
  Dim strOutput As String
  Dim objWord As Object
  Dim objDoc As Object

  Set objPresentation = ActivePresentation
  Set objWord = CreateObject("Word.Application")
  Set objDoc = objWord.Documents.Add

  For Each objSlide In objPresentation.Slides
    For Each objShape In objSlide.Shapes
      If objShape.HasTextFrame Then
        Set objTextFrame = objShape.TextFrame
        Set objTextRange = objTextFrame.TextRange
        strOutput = strOutput & objTextRange.Text & vbCrLf
      End If
    Next
  Next

  objDoc.Range.InsertAfter strOutput
  objDoc.SaveAs "C:\Output.docx"
  objDoc.Close
  objWord.Quit

  MsgBox "文本提取已完成！"
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.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)
            For Each row In pptTable.Rows
                For Each column In pptTable.Columns
                    text = pptTable.Cell(row.Index, column.Index).Shape.TextFrame.TextRange.Text
                    new_table.Cell(row.Index, column.Index).Range!.Text = text
                Next column
            Next row
        ElseIf pptShape.HasTextFrame Then
            text = pptShape.TextFrame.TextRange.Text
            wordDoc.Range.InsertAfter(text)
        End If
    Next 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.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)
            For Each row In pptTable.Rows
                For Each column In pptTable.Columns
                    text = pptTable.Cell(row.Index, column.Index).Shape.TextFrame.TextRange.Text
                    new_table.Rows(row.Index).Cells(column.Index).Range.Text = text
                Next column
            Next row
        ElseIf pptShape.HasTextFrame Then
            text = pptShape.TextFrame.TextRange.Text
            wordDoc.Range.InsertAfter text
        End If
    Next pptShape
Next pptSlide
End Sub