将Excel图表复制/粘贴到PowerPoint并断开链接

Question

我想使用VBA（Excel和PowerPoint 2013）将多个图表复制粘贴到PowerPoint。 只要我不试图断开Excel和PowerPoint之间的图形连接，我下面的宏就可以正常工作-这是我绝对需要做的。

我查看了Google，发现有人建议使用.Breaklink方法：只要我的工作表中只包含一个图形，它就可以很好地工作并且实际上会断开链接。 如果至少有两个图形，它将正确复制第一个图形，然后在处理第二个图形时抛出“ MS PowerPoint已停止工作”消息。

我应该如何进行？

我试图在.Chart.ChartData和.Shape对象上都应用.BreakLink方法无济于事。

    Sub WhyIsThisWrong()
    Application.ScreenUpdating = False
    Dim aPPT As PowerPoint.Application
    Dim oSld As PowerPoint.Slide
    Dim oShp As PowerPoint.Shape
    Dim oCh As ChartObject

      Set aPPT = New PowerPoint.Application
      aPPT.Presentations.Add
      aPPT.Visible = True

      For Each oCh In ActiveSheet.ChartObjects
        oCh.Activate
        ActiveChart.ChartArea.Copy

        aPPT.ActivePresentation.Slides.Add aPPT.ActivePresentation.Slides.Count + 1, ppLayoutText
        Set oSld = aPPT.ActivePresentation.Slides(aPPT.ActivePresentation.Slides.Count)

        oSld.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select

        'Something is wrong here
        With oSld.Shapes(3)
          If .Chart.ChartData.IsLinked Then
            '.Chart.ChartData.BreakLink
            .LinkFormat.BreakLink
          End If
        End With

      Next oCh

    Set oSld = Nothing
    Set aPPT = Nothing
    Application.ScreenUpdating = True
    End Sub

Answer 1

这可能不是您想要的确切答案-它会将图表作为图片粘贴到Powerpoint中。
注意：无需为PP设置参考，并且至少应在XL＆PP 2007、2010和2013上使用。

我已经更新了代码，使其既可以粘贴为图片，也可以粘贴为图表并断开链接。 希望这不是在我的机器上工作的情况之一。

Public Sub UpdatePowerPoint()

    Dim oPPT As Object
    Dim oPresentation As Object
    Dim cht As Chart

    Set oPPT = CreatePPT
    Set oPresentation = oPPT.presentations.Open( _
        "<Full Path to your presentation>")

    oPPT.ActiveWindow.viewtype = 1 '1 = ppViewSlide

    '''''''''''''''''''''''''
    'Copy Chart to Slide 2. '
    '''''''''''''''''''''''''
    oPresentation.Windows(1).View.goToSlide 2
    With oPresentation.Slides(2)
        .Select
        Set cht = ThisWorkbook.Worksheets("MySheetWithAChart").ChartObjects("MyChart").Chart

        ''''''''''''''''''''''''''
        'Paste Chart as picture. '
        ''''''''''''''''''''''''''
'        cht.CopyPicture Appearance:=xlScreen, Format:=xlPicture, Size:=xlScreen
'        .Shapes.Paste.Select

        '''''''''''''''''''''''''''''''''
        'Paste as Chart and break link. '
        '''''''''''''''''''''''''''''''''
        cht.ChartArea.Copy
        .Shapes.Paste.Select
        With .Shapes("MyChart")
            .LinkFormat.BreakLink
        End With

        oPresentation.Windows(1).Selection.ShapeRange.Left = 150
        oPresentation.Windows(1).Selection.ShapeRange.Top = 90
    End With

End Sub

    '----------------------------------------------------------------------------------
    ' Procedure : CreatePPT
    ' Date      : 02/10/2014
    ' Purpose   : Creates an instance of Powerpoint and passes the reference back.
    '-----------------------------------------------------------------------------------
    Public Function CreatePPT(Optional bVisible As Boolean = True) As Object

        Dim oTmpPPT As Object

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'Defer error trapping in case PowerPoint is not running. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        On Error Resume Next
        Set oTmpPPT = GetObject(, "PowerPoint.Application")

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'If an error occurs then create an instance of PowerPoint. '
        'Reinstate error handling.                                 '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo ERROR_HANDLER
            Set oTmpPPT = CreateObject("PowerPoint.Application")
        End If

        oTmpPPT.Visible = bVisible
        Set CreatePPT = oTmpPPT

        On Error GoTo 0
        Exit Function

    ERROR_HANDLER:
        Select Case Err.Number

            Case Else
                MsgBox "Error " & Err.Number & vbCr & _
                    " (" & Err.Description & ") in procedure CreatePPT."
                Err.Clear
        End Select

    End Function