PowerPoint screws up timeline when setting AnimationSettings.AdvanceTime in VBA. How to fix it?
As shown here: https://youtu.be/l2N7A5yZ1iY
I was creating a macro to adjust a presentation of mine when I bumped into a problem with PP.
Try as I might, and searching high and low online, I couldn't get rid of this problem.
I ended up making the adjustments manually, which took me a few hours to make, as the number of animated elements was relatively high (in the low hundreds, but still) -- add to that that my box is NOT a top of the line, and you can see I'm not a happy camper right now, but I digress.
In any case, when the macro tries to set AnimationSettings.AdvanceTime of a newly created animated shape the ENTIRE timeline was corrupted. Every single ANIMATION was set up to After Previous. Every. Single. One.
Is there any way to fix this?
The code, if anyone wants it, is this:
Option Explicit
Public Sub AddThumps()
Dim i As Integer
Dim shp As Shape
Dim sld As Slide
Dim efx1 As Effect
Dim efx2 As Effect
Dim thump As Shape
Dim newThump As Shape
Dim advTime As Single
Set sld = ActivePresentation.Slides(8)
'*
'* Get the “Thump” SFX
'*
For Each shp In sld.Shapes
If (shp.Name = "(SFX) Thump") Then
Set thump = shp
Exit For
End If
Next
Do
i = i + 1
Set efx1 = sld.TimeLine.MainSequence(i)
Set shp = efx1.Shape
If (Left(shp.Name, 7) = "Element") Then
Debug.Print shp.Name, shp.AnimationSettings.AnimationOrder
'*
'* Create a new shape from the media file for the “Thump”
'* and get the delay of the previous element
'*
Set newThump = sld.Shapes.AddMediaObject2("C:\Users\Usuario\Music\(SFX) Thump.m4a", msoFalse, msoTrue)
newThump.Name = thump.Name & " - " & shp.Name
advTime = shp.AnimationSettings.AdvanceTime + efx1.Timing.Duration
'*
'* Create a new effect
'*
Set efx2 = sld.TimeLine.MainSequence.AddEffect(newThump, msoAnimEffectMediaPlay, msoAnimateLevelNone, msoAnimTriggerWithPrevious)
Debug.Print efx2.Shape.Name
Call efx2.MoveAfter(getEffectFromShape(sld, shp))
'*
'* Set the delay
'*
newThump.AnimationSettings.AdvanceTime = advTime
DoEvents
End If
DoEvents
Loop While i < sld.TimeLine.MainSequence.Count
Debug.Print "Done"
End Sub
Private Function getEffectFromShape(sld As Slide, shp As Shape) As Effect
Set getEffectFromShape = Nothing
Dim efx As Effect
For Each efx In sld.TimeLine.MainSequence
If (shp Is efx.Shape) Then
Set getEffectFromShape = efx
Exit Function
End If
Next
End Function
NOTE: This is a repost. I originally posted this question at Microsoft Answers and was asked to post it here too.