Public Sub CopyChartsToPowerPoint()
'
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngKount As Long
'
Dim pptApp As Object 'PowerPoint.Application
Dim pptPres As Object 'PowerPoint.Presentation
Dim pptSld As Object 'PowerPoint.Slide
'
On Error GoTo Error_Para
'
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
'
lngKount = 0
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
Set pptSld = pptPres.Slides.Add(pptPres.Slides.Count + 1, 12)
With objChart
'Copy chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste
End With
lngKount = lngKount + 1
Next objChartObject
End If
Next ws
' Now check CHART sheets:
For Each objCht In ActiveWorkbook.Charts
Set pptSld = pptPres.Slides.Add(pptPres.Slides.Count + 1, 12)
With objCht
'Copy chart object as picture
.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste
End With
lngKount = lngKount + 1
Next objCht
'
If lngKount > 0 Then
If lngKount = 1 Then
MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
Else
MsgBox lngKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
End If
End If
'Activate PowerPoint application
pptApp.Visible = True
pptApp.Activate
GoTo Exit_Para
Error_Para:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & _
Err.Description & vbCrLf & vbCrLf & _
"copying charts to PowerPoint", vbOKOnly + vbCritical, "Error"
Exit_Para:
On Error Resume Next
Set ws = Nothing
Set objChart = Nothing
Set objChartObject = Nothing
Set pptSld = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub