VBA如何从Word复制图像/内联形状到powerpoint

Question

我正在尝试编写一个宏来查找并复制Word文档中的所有图形/图像，并将它们粘贴到新幻灯片中的单个幻灯片中。但是，当我遇到多个运行时错误。这是整个代码。

Sub wordtoppt() 
'This macro copies all pictures out of a word document of your choice and into a new powerpoint presentation. 

'Two reference libraries need to be open - Word and Powerpoint. Go Tools > References, and tick the relevant box. 


Dim wdApp As Word.Application 'Set up word and powerpoint objects 
Dim wdDoc As Word.Document 

Dim pptApp As PowerPoint.Application 
Dim pptShw As PowerPoint.Presentation 
Dim pptChart As PowerPoint.Shape 
Dim pptSld As PowerPoint.Slide 

On Error GoTo 0 

Dim wcount As Integer  'Number of open word documents 
Dim doclist() As String  'Collects the names of open word documents 
Dim desc As String   'inputbox text 
Dim chosendoc As Integer 'stores the index number of your selected word document 
Dim ccount As Integer  'number of shapes in the word document 

Dim wellpasted As Integer 'Counts the number of shapes that have successfully been pasted into powerpoint. 

Application.ScreenUpdating = False 

'Establishes link with word. 
On Error Resume Next 
Set wdApp = GetObject(, "Word.Application") 
On Error GoTo 0 
If wdApp Is Nothing Then 'Error message if Word is not open 
    MsgBox "Error: Word is not open." & Chr(10) & Chr(10) & "Is word actually open? This is a bug." 
    Exit Sub 
End If 

'Counts the number of word documents open 
wcount = CInt(wdApp.Documents.Count) 
ReDim doclist(wcount) 'resizes string array of word documents 
If wcount = 0 Then 'Error message if Word is open, but there are no documents open 
    MsgBox "There are no word documents open!" & Chr(10) & "Open a word document and try again" 
    Exit Sub 
End If 

'text for input box 
desc = "Which document would you like to extract the graphs from?" & Chr(10) & Chr(10) & "Type the number in the box (one number only)." & Chr(10) & Chr(10) 

'input boxes for selection of word document 
If wcount = 1 Then 'if only one document open 
    myinput = MsgBox("Do you want to paste graphs from " & wdApp.Documents(1).Name & "?", vbYesNo, "From Release Note to Powerpoint") 
    If myinput = vbYes Then 
     chosendoc = 1 
    Else 
     Exit Sub 
    End If 
Else 
    For i = 1 To wcount 'multiple documents open 
     doclist(i) = wdApp.Documents(i).Name 
     desc = desc & i & ": " & doclist(i) & Chr(10) 
    Next 
    myinput = InputBox(desc, "From Release Note to Powerpoint") 

    If IsNumeric(myinput) And myinput <= wcount Then 'Error handling - if cancel is clicked, or anything other than a number is typed into the input box. 
     chosendoc = CInt(myinput) 
    Else 
     If myinput = "" Then 'clicking cancel, or leaving input box blank 
      MsgBox "You didn't enter anything!" 
      Exit Sub 
     Else 'if you type a short novel 
      MsgBox "You didn't enter a valid number!" & Chr(10) & "(Your response was " & myinput & ")" 
      Exit Sub 
     End If 
    End If 
End If 

'Error handling, for chart-free word documents. 
If wdApp.Documents(chosendoc).InlineShapes.Count = 0 Then 
    MsgBox "There are no charts in this Word Document!" 
    Exit Sub 
End If 


'Opens a new powerpoint presentation 
Set pptApp = CreateObject("PowerPoint.Application") 
Set pptShw = pptApp.Presentations.Add 

'PowerPoint.Application 
'Sets up slide dimensions 
Dim sldwidth As Integer 
Dim sldheight As Integer 
sldwidth = pptShw.PageSetup.SlideWidth 
sldheight = pptShw.PageSetup.SlideHeight 



wellpasted = 0 


Dim shapecount As Integer 'Number of shapes in the word document 
shapecount = wdApp.Documents(chosendoc).InlineShapes.Count 

For j = 1 To shapecount 'Adds in the correct number of slides into the powerpoint presentation 
Set pptSld = pptShw.Slides.Add(pptShw.Slides.Count + 1, ppLayoutBlank) 
Next 

For j = 1 To shapecount 'loops through all shapes in the document 

On Error GoTo Skiptheloop 'sometimes some objects don't paste. This is a way to skip over them. 

'Application.Wait Now + (1/86400) 

    wdApp.Documents(chosendoc).InlineShapes(j).Range.Copy 'copies chart 

    Set pptSld = pptShw.Slides(j) 

    pptSld.Shapes.Paste 'pastes chart 

'Application.CutCopyMode = False 

    With pptSld.Shapes(1)  'resizes and aligns shapes 
     .LockAspectRatio = msoTrue 'Currently sets charts to the height of the slide. Alternatively can scale to 100% 
     .Height = sldheight 
     .Left = (sldwidth/2) - (.Width/2) 
     .Top = (sldheight/2) - (.Height/2) 
    End With 
    wellpasted = wellpasted + 1 'if the chart was pasted successfully, increment by 1. 

Skiptheloop: 
Next 


On Error GoTo 0 
If (shapecount - wellpasted) <> 0 Then 'produces a message box if some shapes did not paste successfully. 
    MsgBox CStr(shapecount - wellpasted) & " (of " & CStr(shapecount) & ") shapes were not pasted. Best that you check all the graphs are in." 
End If 

Application.ScreenUpdating = True 
pptApp.Activate 'brings powerpoint to the front of the screen 


Exit Sub 

End Sub 

上线pptSld.shapes.paste我得到的错误剪贴板为空或无法粘贴。

任何想法？

Answer 1

我使用两个标准杆

1）从Word文件 这可以通过两种方式来完成提取所有图像devided我的工作简单的解决方案。

a。另存为html，它将创建文件夹filenam_files，该文件夹将保存.png合成文件中的所有图像。差异甲酸盐中可能有重复的图像，但.png将是唯一的。

湾更改文字的文件名从file.docx到file.docx.zip 您可以在file.docx\word\media 获取图像此方法中不会有重复的图像。

2）以powerpoint导入所有图像。

1）

正如你已经打开的文档手动你可以做手工一个步骤或录制宏，将这个样子。

Sub exportimages() 
ChangeFileOpenDirectory "D:\temp\" 
ActiveDocument.SaveAs2 FileName:="data.html", FileFormat:=wdFormatHTML, _ 
    LockComments:=False, passWord:="", AddToRecentFiles:=True, WritePassword _ 
    :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ 
    SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _ 
    False, CompatibilityMode:=0 
End Sub 

2）

关闭Word文档。 打开电源点，并粘贴此

Sub ImportABunch() 

Dim strTemp As String 
Dim strPath As String 
Dim strFileSpec As String 
Dim oSld As Slide 
Dim oPic As Shape 


strPath = "D:\temp\data_files\" 
strFileSpec = "*.png" 'if you are using mehtod **a.** to extract the images. 
'strFileSpec = "*.*" 'if you are using mehtod **b.** to extract the images. 

strTemp = Dir(strPath & strFileSpec) 

Do While strTemp <> "" 
    Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank) 
    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _ 
    LinkToFile:=msoFalse, _ 
    SaveWithDocument:=msoTrue, _ 
    Left:=0, _ 
    Top:=0, _ 
    Width:=-1, _ 
    Height:=-1) 
    strTemp = Dir 
Loop 

End Sub 

你可以写VBScript来这两个步骤结合起来。我不知道该怎么做。你可以谷歌它。