将 Excel 图表粘贴到 PowerPoint 幻灯片中

Posted 2023-02-19

【中文标题】将 Excel 图表粘贴到 PowerPoint 幻灯片中

【英文标题】：Pasting Excel Chart into PowerPoint Slide

【发布时间】：2014-10-15 12:42:00

【问题描述】：

下面的 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

我收到一个运行时错误：

形状（未知成员）：请求无效。剪贴板为空或包含可能无法粘贴到此处的数据。

在线：

pptSlide.Shapes.PasteSpecial DataType:=ppPasteDefault, Link:=msoFalse

Error http://im64.gulfup.com/pZNwxJ.png

我尝试了pptSlide.Shapes.Paste，但它给出了同样的错误。

当我将pptApp.Presentations.Add(msoFalse) 修改为pptApp.Presentations.Add 时，它只能工作，但会显示 PowerPoint 应用程序。

当我更改为.PasteSpecial DataType:=ppPasteEnhancedMetafile 或.PasteSpecial DataType:=ppPastePNG 时，即使使用.Add(msoFalse)，一切也会顺利进行。

我认为这可能与设置焦点有关。

【问题讨论】：

@DavidZemens Nope .Chart.Export FileName:="C:\Users\xyz\Desktop\1.png, FilterName:="PNG" 可以正常工作。然而，在 Excel 2007 SP3 中，使用这种方法生成的图表图像质量非常差。出于某种原因，当粘贴它并从 PowerPoint 中保存时，它会好很多，这也是我采用上述方法的原因。

尝试pptApp.CommandBars.ExecuteMso "PastePng" 方法而不是PasteSpecial。

@DavidZemens pptApp.CommandBars.ExecuteMso "PastePng" 给出了对象“_CommandBars”的方法“ExecuteMso”失败。还有一种工作方法可以粘贴图表本身而不是将其粘贴为 PNG？

见THIS直接粘贴图表。

@DavidZemens 感谢您的链接；但尝试pptApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting" 失败，对象'_CommandBars' 的方法'ExecuteMso' 失败。这是我的样本表的链接：db.tt/nGrgF5bA

【参考方案1】：

PasteSpecial 和 CommandBars.ExecuteMso 应该都可以工作（在 Excel/PowerPoint 2010 中测试了您的代码，并注意以下几点：

添加演示文稿时，必须打开它WithWindow:=True

Set pptPres = pptApp.Presentations.Add(msoCTrue)

我做了更多的挖掘，你需要使用CopyPicture方法然后我认为你可以用window=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

【讨论】：

看起来很整洁，但是它再次复制了图表的图像，而不是实际的图表本身:(

无论如何，您都将其导出为图像，并杀死了临时 PPT 文件。以这种方式完成后，PNG 质量是否会明显下降？

让我试试看，明天我会再做（因为我想在办公室的工作中测试它）。我将运行这两个代码并查看它们在同一张图表中的质量差异。我会及时通知你:)

是的，它看起来确实很糟糕......我认为这可能是一个“黑客”可能是唯一解决方案的地方......

【参考方案2】：

这是我们在将信息从一个 Office 应用程序复制到另一个应用程序时可能遇到的常见错误。我能描述它的最好方式是程序运行得太快，我们复制的信息实际上并没有进入我们的剪贴板。

这意味着当我们尝试粘贴它时，我们会收到一个错误，因为我们的剪贴板中没有要粘贴的内容。

现在幸运的是，有一种方法可以修复此错误，但它需要我们添加额外的代码行。

'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

现在我所做的只是添加一行额外的代码，让您的 Excel 应用程序暂停一秒钟。这将给它足够的时间来确保信息存储在您的剪贴板中。 p>

您可能会问为什么有时会发生这种情况，但有时却不会。 好吧，归根结底，剪贴板可能会发生不可预测的行为并清除其中的信息。

这就是为什么如果我们可以避免将信息存储在我们尝试的剪贴板中。但是，在这种情况下，我们无法避免它，所以我们只能忍受不可预测性。

【参考方案3】：

如果 PowerPoint 有 Application.Wait 消息，@areed1192 的回答可能有效，但这是 Excel 的问题。

通过使用此处找到的技术，我能够做类似的事情：

也就是说，在模块的顶部放一个：

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

然后这样称呼它：

Sleep 1000
DoEvents

（我不肯定 DoEvents 有帮助，但如果发生这种情况，解决 VBA 中的竞争条件似乎是个好主意。）

【参考方案4】：

sld.Shapes.PasteSpecial 数据类型：=0

或

sld.Shapes.PasteSpecial DataType:=ppPasteShape