Question

我目前正在使用vba自动创建ppt报告。我需要从excel复制图表并粘贴到ppt。我成功地使用了ExecuteMso＆＃34; PasteExcelChartSourceFormatting＆＃34;粘贴图表，我需要使用，所以我可以粘贴，同时保持源格式和嵌入工作簿，但在我的代码尝试在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

我收到运行时错误＆＃39; - 2147188160（80048240）＆＃39;，方法＆＃39;项目＆＃39;对象＆＃39;形状＆＃39;失败。调试突出显示了我代码的最后几行。

非常感谢任何建议！

Answer 1

我知道这对游戏来说有点晚了，但是我使用这篇文章尝试回答我遇到的相同问题。当我找到解决方案时，我想把它还给我。

现在我的代码有所不同，因为我正在为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循环”有助于避免此错误。宏的确需要一些时间才能完成，具体取决于您拥有多少张图表。

Answer 2

你可以试试这个稍微不同的方法

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。

使用它将图表从excel发布到ppt后执行错误

2 个答案: