PowerPoint Animationsdetails ins Excel

Sub List_PPT_Transitions()
Dim sPPTFile As String
Dim rKopfzeile As Range
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim i As Long
sPPTFile = Range("PPTFile").Value
Set rKopfzeile = Range("Kopfzeile")
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoTrue
Set pptPres = pptApp.Presentations.Open(sPPTFile)
i = 0
For Each pptSlide In pptPres.Slides
i = i + 1
With rKopfzeile.Offset(i, 0)
.Cells(1).Value = i
.Cells(2).Value = pptSlide.Name
.Cells(3).Value = pptSlide.SlideShowTransition.EntryEffect
End With
Next pptSlide
pptPres.Close
pptApp.Quit
Set pptApp = Nothing
End Sub