ppt_VBA 从word文档提取图片到ppt逐页平铺

'PPT 加载宏 代码模板
Dim cmdBar As CommandBar, cmdBtn As CommandBarControl
Const cmdBtnCap As String = "从Word文档导入图片"
Sub Auto_Open()
    Call DelCmdBtn
    Call AddCmdBtn
End Sub
Sub Auto_Close()
    Call DelCmdBtn
End Sub
Sub AddCmdBtn()
    Set cmdBar = Application.CommandBars("Tools")
    Set cmdBtn = cmdBar.Controls.Add(msoControlButton)
    With cmdBtn
        .Caption = cmdBtnCap
        .Style = msoButtonCaption
        .OnAction = "pptGetImagesFromWord2"
    End With
    Set cmdBtn = Nothing
    Set cmdBar = Nothing
End Sub
Sub DelCmdBtn()
    Set cmdBar = Application.CommandBars("Tools")
    For Each cmdBtn In cmdBar.Controls
        If cmdBtn.Caption = cmdBtnCap Then cmdBtn.Delete
    Next
    Set cmdBtn = Nothing
    Set cmdBar = Nothing
End Sub
Sub pptGetImagesFromWord2()
    Dim wdApp As Object
    Dim doc As Object
    Dim docPath As String
    Dim ishp
    Dim count As Long
    
    Dim pre As Presentation
    Dim sld As Slide, shp As Shape
    
      With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ActivePresentation.Path
        .Filters.Clear
        .Filters.Add "Word文档2003~2016", "*.doc*"
        .AllowMultiSelect = False
        .Title = "请选择图片所在的Word文档"
        If .Show = -1 Then
            docPath = .SelectedItems(1)
        Else
            MsgBox "您已取消选择，按“确定”退出程序。"
            Exit Sub
        End If
    End With
 On Error GoTo errh
    Set wdApp = CreateObject("word.application")
    Set doc = wdApp.documents.Open(docPath)
    

   Do While doc.Shapes.count > 0
        For Each ishp In doc.Shapes
             ishp.ConvertToInlineShape
        Next ishp
    Loop
    
    Set pre = Application.Presentations.Add(msoTrue)
    pre.SaveAs Replace(docPath, ".doc", ".ppt")
    With pre.PageSetup
        SW = .SlideWidth
        SH = .SlideHeight
        PageRate = SW / SH
    End With
    
    Do While pre.Slides.count >= 2
        pre.Slides(2).Delete
    Loop
    
    For Each ishp In doc.inlineshapes
           '选中-复制
            ishp.Select
            wdApp.Selection.Copy
            '新建幻灯片，粘贴
            Set sld = pre.Slides.Add(pre.Slides.count + 1, ppLayoutBlank)
            sld.Select
            sld.Shapes.Paste
            Set shp = sld.Shapes(1)
             '取消锁定纵横比
             shp.LockAspectRatio = msoFalse
            shp.ScaleHeight 1, msoTrue
            shp.ScaleWidth 1, msoTrue
            shpWidth = shp.Width
            shpHeight = shp.Height
            ShpRate = shpWidth / shpHeight

            '锁定纵横比
             shp.LockAspectRatio = msoTrue
            If ShpRate >= PageRate Then    '图片更宽
                shp.Width = SW
                shpHeight = shp.Height
                shp.Top = SH / 2 - shpHeight / 2
                shp.Left = 0
            Else    '图片更高
                shp.Height = SH
                shpWidth = shp.Width
                shp.Left = SW / 2 - shpWidth / 2
                shp.Top = 0
            End If
            
    Next ishp
    doc.Close False
    
errh:

    pre.Save
    pre.Close
   wdApp.Quit
   Set doc = Nothing
   Set sld = Nothing
   Set pre = Nothing
    
End Sub