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來這兩個步驟結合起來。我不知道該怎麼做。你可以谷歌它。