PowerPoint screws up timeline when setting AnimationSettings.AdvanceTime in VBA. How to fix it?

PaulStSmith 75 Reputation points

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

        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

        End If

    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
End Function

NOTE: This is a repost. I originally posted this question at Microsoft Answers and was asked to post it here too.

A family of Microsoft presentation graphics products that offer tools for creating presentations and adding graphic effects like multimedia objects and special effects with text.
216 questions
Office Development
Office Development
Office: A suite of Microsoft productivity software that supports common business tasks, including word processing, email, presentations, and data management and analysis.Development: The process of researching, productizing, and refining new or existing technologies.
3,465 questions
0 comments No comments
{count} votes