vba 将 Excel 图表粘贴到 PowerPoint 幻灯片中
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/25433826/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Pasting Excel Chart into PowerPoint Slide
提问by CaptainABC
The below Sub is supposed to paste an Excel chart into a newly created PowerPoint slide. It then exports the chart as a PNG:
下面的 Sub 应该将 Excel 图表粘贴到新创建的 PowerPoint 幻灯片中。然后将图表导出为 PNG：
Sub ChartsToPowerPoint()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
'Open PowerPoint and create an invisible new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add(msoFalse)
'Set the charts and copy them to a new ppt slide
Set objChart = Worksheets("Sheet1").ChartObjects("Chart 1").Chart
objChart.ChartArea.Copy
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
pptSlide.Shapes.PasteSpecial DataType:=ppPasteDefault, Link:=msoFalse
'Save Images as png
path = "C:\Users\xyz\Desktop\"
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
.Export path & j & ".png", ppShapeFormatPNG
End With
Next j
pptApp.Quit
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
I get a Run-time error:
我收到一个运行时错误：
Shapes (unknown member): Invalid request. Clipboard is empty or contains data which may not be pasted here.
形状（未知成员）：请求无效。剪贴板为空或包含可能无法粘贴到此处的数据。
At the line:
在线：
pptSlide.Shapes.PasteSpecial DataType:=ppPasteDefault, Link:=msoFalse
Error http://im64.gulfup.com/pZNwxJ.png
错误 http://im64.gulfup.com/pZNwxJ.png
I tried pptSlide.Shapes.Pastebut it gives the same error.
我试过了，pptSlide.Shapes.Paste但它给出了同样的错误。
When I amend pptApp.Presentations.Add(msoFalse)to pptApp.Presentations.Addonly it works but the PowerPoint App is displayed.
当我修改pptApp.Presentations.Add(msoFalse)为pptApp.Presentations.Add仅它有效但显示 PowerPoint 应用程序时。
When I change to .PasteSpecial DataType:=ppPasteEnhancedMetafileor .PasteSpecial DataType:=ppPastePNGeverything runs smoothly even with .Add(msoFalse).
当我更改为.PasteSpecial DataType:=ppPasteEnhancedMetafile或者.PasteSpecial DataType:=ppPastePNG即使使用.Add(msoFalse).
I am thinking it might be something to do with setting the focus or so.
我认为这可能与设置焦点有关。
采纳答案by David Zemens
PasteSpecialand CommandBars.ExecuteMsoshould both work (tested your code in Excel/PowerPoint 2010 with the following caveat:
PasteSpecial并且CommandBars.ExecuteMso应该都可以工作（在 Excel/PowerPoint 2010 中测试了您的代码，注意事项如下：
When you add presentation, you have to open it WithWindow:=True
添加演示文稿时，您必须将其打开 WithWindow:=True
Set pptPres = pptApp.Presentations.Add(msoCTrue)
I did some more digging, you need to use the CopyPicturemethod and then I think you can open withwindow=False. Try:
我做了一些更多的挖掘，你需要使用该CopyPicture方法，然后我认为你可以打开 withwindow= False。尝试：
Sub ChartsToPowerPoint()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim objChart As Chart
'Open PowerPoint and create an invisible new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add(msoFalse)
Set objChart = Worksheets("Sheet1").ChartObjects("Chart 1").Chart
objChart.CopyPicture
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
pptSlide.Shapes.PasteSpecial DataType:=ppPasteDefault, Link:=msoFalse
'Save Images as png
Path = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & "\"
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
.Export Path & j & ".png", ppShapeFormatPNG
End With
Next j
pptApp.Quit
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
回答by areed1192
This is a common error we can experience when we copy information from one Office application to another. The best way I can describe it is that the program runs too fast and the information we copy never actually makes it into our clipboard.
这是我们将信息从一个 Office 应用程序复制到另一个时可能遇到的常见错误。我能描述它的最好方式是程序运行得太快，我们复制的信息实际上从未进入我们的剪贴板。
This means that when we go and try to paste it, we get an error because there is nothing in our clipboard to paste.
这意味着当我们去尝试粘贴它时，我们会收到一个错误，因为剪贴板中没有任何东西可以粘贴。
Now lucky for us there is a way to fix this error but it requires us to add an extra line of code.
现在幸运的是，有一种方法可以修复此错误，但它需要我们添加额外的代码行。
'Copy the chart
Set objChart = Worksheets("Sheet1").ChartObjects("Chart 1").Chart
objChart.CopyPicture
'Pause the application for ONE SECOND
Application.Wait Now + #12:00:01 AM#
'Paste your content into a slide as the "Default Data Type"
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
pptSlide.Shapes.PasteSpecial DataType:=ppPasteDefault, Link:=msoFalse
Now all I did was add an extra line of code that pauses your Excel application for one second.This will give it enough time to make sure that the information is stored in your clipboard.
现在我所做的只是添加一行额外的代码，让您的 Excel 应用程序暂停一秒钟。这将给它足够的时间来确保信息存储在剪贴板中。
You might be asking the question why does this happen sometimes but then not other times. Well, it just boils down to this the clipboard can act unpredictably and clear out information inside of it.
您可能会问为什么有时会发生这种情况，但有时不会。好吧，归根结底就是剪贴板可能会出现不可预测的行为并清除其中的信息。
That's why if we can avoid storing the information in the clipboard we try to. However, in this case, we can't avoid it so we just have to live with the unpredictability.
这就是为什么我们可以避免将信息存储在剪贴板中的原因。然而，在这种情况下，我们无法避免它，所以我们只能忍受不可预测性。
回答by Marc Stober
@areed1192's answer might work if PowerPoint had an Application.Wait message, but that's an Excel thing.
如果 PowerPoint 有 Application.Wait 消息，@areed1192 的答案可能会有效，但这是 Excel 内容。
I was able to do something similar by using a technique found here:
通过使用此处找到的技术，我能够做类似的事情：
Which is to say, put a the top of the module:
也就是说，在模块的顶部放一个：
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
And then call it like this:
然后像这样调用它：
Sleep 1000
DoEvents
(I'm not positive the DoEvents helped, but it seemed like it might be a good idea for resolving a race condition in VBA if that's what's going on.)
（我不认为 DoEvents 有帮助，但如果发生这种情况，在 VBA 中解决竞争条件似乎是个好主意。）
回答by Tarun Reddy
sld.Shapes.PasteSpecial DataType:=0
sld.Shapes.PasteSpecial 数据类型：=0
or
或者
sld.Shapes.PasteSpecial DataType:=ppPasteShape
sld.Shapes.PasteSpecial DataType:=ppPasteShape
