Option Explicit
Enum PpPasteDataType
ppPasteOLEObject = 10
End Enum
Sub Bsp()
Dim objPP As Object
Dim objPres As Object
Dim objShpRange As Object
Set objPP = GetPowerPoint()
Set objPres = objPP.Presentations.Open("D:\Präsentation1.pptx")
Call Worksheets("Tabelle1").Shapes("Chart 3").Chart.ChartArea.Copy
Set objShpRange = objPres.Slides(1).Shapes.PasteSpecial(ppPasteOLEObject)
Call MsgBox(objShpRange.Count & " Shape(s) eingefügt" & vbNewLine & _
"Name(1) = '" & objShpRange(1).Name & "'")
Call objPres.Close
End Sub
Public Function GetPowerPoint() As Object
On Error Resume Next
Set GetPowerPoint = GetObject(Class:="PowerPoint.Application")
If GetPowerPoint Is Nothing Then
Set GetPowerPoint = CreateObject("PowerPoint.Application")
GetPowerPoint.Visible = True
End If
End Function