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

Question

I want to copy paste several charts to PowerPoint using VBA (Excel and PowerPoint 2013). My macro below works fine as long as I don't try to break the graph connection between Excel and PowerPoint - which I absolutely need to do.

I've looked up on Google and found people suggesting to use the .Breaklink method: it works quite great and actually breaks the links as long as there is no more than one graph on my sheet. If there are at least two graphs, it will properly copy the first one and then throw a "MS PowerPoint has stopped working" message while working on the second graph.

How should I proceed?

I've tried to apply the .BreakLink method on both the .Chart.ChartData and .Shape objects to no avail.

    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

This may not be the exact answer you're after - it pastes the charts into Powerpoint as pictures.
NB: No references need to be set to PP and should work on at least XL & PP 2007, 2010 & 2013.

I've updated the code to have both paste as picture and paste as chart and break links. Hopefully it's not one of those cases where it works on my machine..

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