vba - 对象形状的粘贴特殊失败vba

Question

我有这段代码可以将 Excel 2010 工作表中的图表复制到 powerpoint 中。它循环搜索事件工作表上的所有图表，然后将链接复制并粘贴到 powerpoint 中。还有一小段代码，用于获取图表标题并将其作为标题放入 PowerPoint 中。

在大多数情况下，它对我来说工作得很好，但是它给了我一个运行时错误 -2147467259 (80004005) 在将 9 个图表移入 powerpoint 后，对象“Shapes”的方法“PasteSpecial”失败。完美运行过程中出现此故障可能是什么原因造成的？

Sub CreatePowerPoint()

 'Add a reference to the Microsoft PowerPoint Library by:

    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PowerPoint
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(Link:=True).Select

    'Set the title of the slide the same as the title of the chart
        If ActiveChart.HasTitle = True Then
            activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
        Else
            activeSlide.Shapes(1).TextFrame.TextRange.Text = "Add Title"
        End If
    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0.5 * 72
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 1.75 * 72
        newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 5.5 * 72
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 8.92 * 72

       Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

End Sub

Answer 1

原因很简单。您没有给 Excel 足够的时间将图表复制到剪贴板。

试试这个

    ActiveChart.ChartArea.Copy
    DoEvents
    activeSlide.Shapes.PasteSpecial(Link:=True).Select