VBA 如何将图像/内联形状从 Word 复制到 powerpoint
VBA how to copy images / inline shapes from Word to powerpoint
我正在尝试编写一个宏来查找并复制 word 文档中的所有 graphs/images 内联内容，然后将它们粘贴到新 powerpoint 中的各个幻灯片中。然而当我 运行 进入多个 运行 时出错。这是完整的代码。
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我收到错误剪贴板为空或无法粘贴。
有什么想法吗？
我将我的工作分为两部分使用简单的解决方案
1) 从word文件中提取所有图片
这可以通过两种方式完成。
a. 另存为 html，这将创建文件夹 filenam_files，该文件夹将保存 .png 格式中的所有图像。 diff 格式中可能存在重复图像，但 .png 将是唯一的。
b. 将单词的文件名从 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文档。
打开 PowerPoint 并粘贴这个
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 将这两个步骤组合在一起。我不知道该怎么做。你可以 google 它。
我正在尝试编写一个宏来查找并复制 word 文档中的所有 graphs/images 内联内容，然后将它们粘贴到新 powerpoint 中的各个幻灯片中。然而当我 运行 进入多个 运行 时出错。这是完整的代码。
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我收到错误剪贴板为空或无法粘贴。
有什么想法吗？
我将我的工作分为两部分使用简单的解决方案
1) 从word文件中提取所有图片 这可以通过两种方式完成。
a. 另存为 html，这将创建文件夹 filenam_files，该文件夹将保存 .png 格式中的所有图像。 diff 格式中可能存在重复图像，但 .png 将是唯一的。
b. 将单词的文件名从 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文档。 打开 PowerPoint 并粘贴这个
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 将这两个步骤组合在一起。我不知道该怎么做。你可以 google 它。