WordVba 借助PPT将Word页面内容导出为图片文件

Sub ExportImages()
    Dim doc As Document
    Dim folderPath As String
    Dim pageCount As Long
    Dim i As Long
    Dim pApp As Object
    Dim pre As Object
    Dim sld As Object
    Set pApp = CreateObject("Powerpoint.Application")

    Set doc = Application.ActiveDocument
    doc.Activate
    folderPath = doc.Path & "\"
    dPageHeight = doc.PageSetup.PageHeight
    dPageWidth = doc.PageSetup.PageWidth
    dPageLeft = doc.PageSetup.LeftMargin
    dPageright = doc.PageSetup.RightMargin
    pageCount = Selection.Information(wdNumberOfPagesInDocument)
    Selection.HomeKey wdStory    \'将光标移至当前内容的开始

    Set pre = pApp.presentations.Add
    Set sld = pre.slides.Add(1, 12)

    For n = 1 To pageCount
        RngStart = Selection.Range.Start    \'当前页开始字符数
        If n = pageCount Then    \'如果是最后一页
            RngEnd = doc.Content.End    \'最后一页的终止字符数
        Else
            RngEnd = Selection.GoToNext(wdGoToPage).End  \'当前页的终止字符数
            Selection.GoToPrevious wdGoToPage    \'将光标移至当前页文字部分的开始
        End If

        doc.Range(RngStart, RngEnd).Copy    \'复制word文档当前页的所有对象

        sld.Select
        For Each shp In sld.Shapes
            shp.Delete
        Next shp

        Set des = pApp.ActiveWindow.View.Slide
        With des
            Set shp = .Shapes.PasteSpecial(2)

            shp.Width = shp.Width * 3
            shp.Height = shp.Height * 3
            shp.Left = 0    \'dPageLeft
            shp.Top = 0    \'dPageright
          
          
        End With

        With pre.PageSetup
            .SlideWidth = shp.Width * 1.05 \'dPageWidth
            .SlideHeight = shp.Height * 1.05  \'dPageHeight
        End With
        
        \'设置图片居中
        
            shp.Left = shp.Width * 0.025    \'dPageLeft
            shp.Top = shp.Height * 0.025
      

        sld.Export folderPath & Split(doc.Name, ".")(0) & n & ".jpg", "JPG", pre.PageSetup.SlideWidth, pre.PageSetup.SlideHeight
        Selection.GoToNext wdGoToPage
        \'Stop
    Next n

    pre.Close
    pApp.Quit

End Sub