Diagramm Powerpoint

Sub CreatePPT()
Dim ppt As Object
Dim oPPT As PowerPoint.Application
Dim oPrs As PowerPoint.Presentation
Dim oSld As PowerPoint.slide
Dim oPct As PowerPoint.Shape
Dim oTxt As PowerPoint.Shape
Dim sPath As String
sPath = Application.DefaultFilePath & "/xl2ppt.ppt"
Set oPPT = CreateObject("PowerPoint.Application")
Set oPrs = oPPT.Presentations.Open("Dateiname+PFad")
Sheets("Diagramm2").Select
ActiveChart.ChartArea.Copy
Set oTxt = oSld.Shapes(1)
With oTxt
.Left = 50
.Top = 0
.Width = 650
.Height = 50
With .TextFrame
With .TextRange
With .Font
.name = "Arial"
.Size = 24
.Bold = msoCTrue
End With
End With
.AutoSize = ppAutoSizeShapeToFitText
End With
End With
With oTxt.AnimationSettings
.Animate = msoTrue
.EntryEffect = ppEffectBoxIn
.TextLevelEffect = ppAnimateByAllLevels
.AnimateBackground = msoTrue
.TextUnitEffect = ppAnimateByCharacter
.AdvanceMode = ppAdvanceOnTime
End With
Set oPct = oSld.Shapes.Paste(1)
oPrs.SaveAs sPath
oPrs.Close
Set oPct = Nothing
Set oTxt = Nothing
Set oSld = Nothing
Set oPrs = Nothing
Set oPPT = Nothing
Application.Wait Now + TimeSerial(0, 0, 3)
Set ppt = GetObject(sPath)
ppt.SlideShowSettings.Run
End Sub