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

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119

'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