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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.