VBA - 如何在将Excel图表粘贴到PowerPoint后应用图表模板

Question

Sub printDashboard()

    Dim sheet1 As Excel.Worksheet
    Set sheet1 = ActiveWorkbook.Sheets("PM Dashboard")

    Dim pptChart2 As Excel.ChartObject

    'Open PowerPoint template
    Dim sPath As String
    sPath = ActiveWorkbook.Path
    Dim pp As PowerPoint.Application, pps As PowerPoint.Presentation
    Set pp = New PowerPoint.Application
    pp.Visible = True
    Set pps = pp.Presentations.Open(sPath & "\template_Slides.pptx")
    Dim firstSlide As PowerPoint.Slide
    Set firstSlide = pps.Slides(1)    

    'Paste the second chart
    Set pptChart2 = sheet1.ChartObjects("chartPM2")
    pptChart2.Copy
    Dim myShape2 As Object
    Set myShape2 = firstSlide.Shapes.PasteSpecial()
    'myShape2.Chart.ApplyChartTemplate (sPath & "\pipelineManagementChartFormat.crtx")
    With myShape2
        .Top = 1.52 * 72
        .Left = 5.33 * 72
        .Width = 4.08 * 72
        .Height = 2.6 * 72
    End With

End Sub

所以这段代码的完美之处在于它：

• 正确打开PowerPoint文件
• Excel图表被粘贴并调整大小/重新定位

但是，我无法弄清楚如何应用我在同一目录中保存的图表模板。 您可以看到我已尝试使用“粘贴第二个图表”部分中注释掉的“ApplyChartTemplate”行来完成此操作。

我很感激这里的任何帮助。 在将图表模板粘贴到幻灯片后，我尝试了许多不同的方法来应用它。 我还没有取得任何成功。

谢谢

Answer 1

它可能是与机器相关的计时问题（从剪贴板粘贴可能导致在粘贴操作完成之前VBA代码正在运行）。 尝试在PasteSpecial行之后立即调用此Delay子。

Delay 1, True

Public Sub Delay(Seconds As Single, Optional DoAppEvents As Boolean)
  Dim TimeNow As Long
  TimeNow = Timer
  Do While Timer < TimeNow + Seconds
    If DoAppEvents = True Then DoEvents
  Loop
End Sub

Answer 2

PasteSpecial返回一个shaperange，而不是shape，但您需要将模板应用于单个形状（即图表对象）。 试试这个：

Set myShape2 = firstSlide.Shapes.PasteSpecial()(1)