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

mosherk

已于 2023-03-30 23:00:53 修改

阅读量768

点赞数 1

分类专栏：解决方法文章标签： word powerpoint

于 2023-03-27 15:07:52 首次发布

本文链接： https://blog.csdn.net/wilix/article/details/129795270

版权

解决方法专栏收录该内容

6 篇文章 0 订阅

订阅专栏

文章提供了几个VBA代码示例，详细说明了如何在PowerPoint中启用开发工具，然后通过编写代码将幻灯片中的文本（包括表格内容）提取到Word文档中。尽管某些代码可能导致错误，但它们展示了自动化文档处理的方法。

摘要由CSDN通过智能技术生成

步骤有空再写

一、步骤

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

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

找到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。如果有懂得的大佬可以说说，感谢😋

第一种

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

第二种

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

第三种

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

第四种

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