使用它 post 从 excel 到 ppt 的图表后，Executemso 出错

Question

我目前正在使用 vba 自动创建 ppt 报告。我需要从 excel 复制图表并粘贴到 ppt 中。我成功地使用 ExecuteMso "PasteExcelChartSourceFormatting" 将图表粘贴到其中，我需要使用它以便在粘贴时保持源格式并嵌入工作簿，但是当我的代码尝试重新定位ppt中的图表。见代码：

Sub Update()

    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide


    Set ppApp = New PowerPoint.Application

    ppApp.Visible = True
    ppApp.Activate

    Set ppPres = ppApp.Presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")

    ppPres.Slides(1).Shapes(7).Delete
    Sheet1.ChartObjects("Chart 24").Chart.ChartArea.Copy
    ppPres.Slides(1).Select
    DoEvents

    ppApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
    ppApp.CommandBars.ReleaseFocus
    DoEvents

    ppPres.Slides(1).Shapes(7).Left = _
      (ppPres.PageSetup.SlideWidth / 2) - (ppPres.Slides(1).Shapes(7).Width / 2)
    ppPres.Slides(1).Shapes(7).Top = 77

End Sub

我收到运行时间错误“--2147188160 (80048240)”，对象 'Shapes' 的方法 'Item' 失败。调试突出显示了我代码的最后几行。

如有任何建议，我们将不胜感激！

Answer 1

你能试试这个吗，方法略有不同

Sub Update()
    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide

    Set ppApp = New PowerPoint.Application

    ppApp.Visible = True
    ppApp.Activate

    Set ppPres = ppApp.Presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
    Set ppSlide = ppPres.Slides(1)
    ppSlide.Shapes(7).Delete

    Sheet1.ChartObjects(1).Chart.ChartArea.Copy

    ppSlide.Shapes.Paste.Select

    With ppPres.Windows(1).Selection.ShapeRange
        .Left = (ppPres.PageSetup.SlideWidth / 2) - (.Width / 2)
        .Top = 77
    End With

End Sub

更新： 我把它分成两个子。你能试试这个吗

Sub Update()
    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide

    Set ppApp = New PowerPoint.Application

    ppApp.Visible = True
    ppApp.Activate

    Set ppPres = ppApp.presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
    Set ppSlide = ppPres.Slides(1)
    ppSlide.Shapes(7).Delete

    Call CopyAndPasteChart(ppApp, ppSlide)

    With ppSlide.Shapes(ppSlide.Shapes.Count)
       .Left = (ppPres.PageSetup.SlideWidth / 2) - (.Width / 2)
       .Top = -77
    End With
    ppApp.CommandBars.ReleaseFocus

End Sub

Sub CopyAndPasteChart(ppApp As PowerPoint.Application, ppSlide As PowerPoint.Slide)
    Sheet1.ChartObjects(1).Chart.ChartArea.Copy
    ppApp.CommandBars.ExecuteMso ("PasteExcelChartSourceFormatting")
End Sub

如果您想让 CopyAndPasteChart Sub 在更多情况下可用，您可以对其进行更多编辑。

Answer 2

我知道这有点晚了，但我用这个 post 来尝试回答我遇到的同样问题。当我找到解决方案时，我想将它付诸实践。

现在我的代码有点不同，因为我要为 excel 工作表中的每个图表创建一张新幻灯片，但我也需要保留源格式。

Dim PowerPointApp As Object
Dim CurrentSlide As Object
Dim PowerPointDoc As Object
Dim xChart As ChartObject
Dim wb As Workbook
Dim ws As Worksheet
Dim Chart As ChartObject
Dim Sheet As Worksheet
Dim x As Long

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

Set PowerPointApp = CreateObject("Powerpoint.Application")
Set PowerPointDoc = PowerPointApp.Presentations.Add(msoTrue)
PowerPointApp.Visible = True

For Each Chart In ws.ChartObjects
    PowerPointApp.ActivePresentation.Slides.Add 
    PowerPointApp.ActivePresentation.Slides.count + 1, 12
    Set CurrentSlide = PowerPointDoc.Slides(PowerPointDoc.Slides.count)
    CurrentSlide.Select
    Chart.Copy
    PowerPointApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"

    '**********************************
    Do
        DoEvents
    Loop Until CurrentSlide.Shapes.count > 0
    '**********************************

Next Chart

"Do While Loop" 帮助避免了这个错误。完成宏确实需要一些时间，具体取决于您拥有的图表数量。

使用它 post 从 excel 到 ppt 的图表后，Executemso 出错

Executemso error after using it to post a chart from excel to ppt

excel

powerpoint

vba