将PPT中的文本和图片转换为word文档

lhm667788

Sub ExtractTextAndImagesToWord()
    Dim slide As slide
    Dim shape As shape
    Dim text As String
    Dim filePath As String
    Dim pres As Presentation
    Dim wordApp As Object ' Word.Application
    Dim wordDoc As Object ' Word.Document
    Dim picIndex As Integer
    Dim picTempPath As String
    Dim tempFolder As String
    Dim rng As Object ' Word.Range

    On Error GoTo ErrorHandler
    Set pres = ActivePresentation

    ' 检查文件是否已保存
    If pres.Path = "" Then
        MsgBox "请先保存演示文稿再运行此宏", vbExclamation
        Exit Sub
    End If

    ' 创建临时文件夹存放图片
    tempFolder = pres.Path & "\PPT_Extract_Temp"
    If Dir(tempFolder, vbDirectory) = "" Then
        MkDir tempFolder
    End If

    ' 构建Word文件路径
    filePath = pres.Path & "\" & _
              Left(pres.Name, InStrRev(pres.Name, ".") - 1) & ".docx"

    ' 创建Word应用程序
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True
    Set wordDoc = wordApp.Documents.Add
    Set rng = wordDoc.Content

    ' 遍历所有幻灯片和形状
    For Each slide In pres.Slides
        For Each shape In slide.Shapes
            ' 处理文本
            If shape.HasTextFrame Then
                If shape.TextFrame.HasText Then
                    text = shape.TextFrame.TextRange.Text
                    ' 写入Word文档
                    rng.InsertAfter text & vbCr
                End If
            End If

            ' 处理图片
            If shape.Type = msoPicture Or shape.Type = msoLinkedPicture Then
                picIndex = picIndex + 1
                picTempPath = tempFolder & "\Pic" & picIndex & ".png"

                ' 导出图片到临时文件夹
                shape.Export picTempPath, ppSaveAsPNG

                ' 在Word文档中插入图片
                rng.Collapse Direction:=0 ' wdCollapseEnd
                rng.InsertParagraphAfter
                wordDoc.InlineShapes.AddPicture picTempPath, LinkToFile:=False, SaveWithDocument:=True, Range:=rng
                rng.Collapse Direction:=0 ' wdCollapseEnd
                rng.InsertParagraphAfter
            End If
        Next shape

        ' 每张幻灯片后添加分页符
        rng.Collapse Direction:=0 ' wdCollapseEnd
        rng.InsertBreak Type:=7 ' wdPageBreak
    Next slide

    ' 删除最后的多余分页符
    rng.MoveEnd
    rng.Delete

    ' 保存Word文档
    wordDoc.SaveAs2 filePath
    MsgBox "文本和图片已成功提取到：" & vbCrLf & filePath, vbInformation

    ' 清理临时文件夹
    Kill tempFolder & "\*.*"
    RmDir tempFolder
    Exit Sub

ErrorHandler:
    If Not wordDoc Is Nothing Then
        wordDoc.Close SaveChanges:=False
    End If
    If Not wordApp Is Nothing Then
        wordApp.Quit
    End If
    If Dir(tempFolder, vbDirectory) <> "" Then
        Kill tempFolder & "\*.*"
        RmDir tempFolder
    End If
    MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical
End Sub

踏破拖鞋

谢谢分享  好用

592rmb

这个应该很有用，感谢老师分享