Sub ExcelToExistingPowerPoint()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
' Make sure a chart is selected
If ActiveChart Is Nothing Then
MsgBox "Selecteer een grafiek en probeer opnieuw.", vbExclamation, _
"Geen grafiek geselecteerd"
Else
' Reference instance of PowerPoint
On Error Resume Next
' Check whether PowerPoint is running
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
' PowerPoint is not running, create new instance
Set PPApp = CreateObject("PowerPoint.Application")
PPApp.Visible = True
End If
On Error GoTo 0
' Reference presentation and slide
On Error Resume Next
If PPApp.Windows.Count > 0 Then
' There is at least one presentation
' Use existing presentation
Set PPPres = PPApp.ActivePresentation
' Use active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Else
' There are no presentations
' Create new presentation
Set PPPres = PPApp.Presentations.Add
' Add first slide
Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
End If
On Error GoTo 0
' Some PowerPoint actions work best in normal slide view
PPApp.ActiveWindow.ViewType = ppViewSlide
' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
' Paste chart
PPSlide.Shapes.Paste.Select
' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'Save presentation to desired path
With PPPres
.SaveAs "D:\Mijn documenten\Nieuwe Presentatie.ppt"
.Close
End With
' Quit PowerPoint
PPApp.Quit
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub
