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

PaulStSmith 75 Reputation points
2023-09-10T00:42:52.6566667+00:00

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.

PowerPoint
PowerPoint
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.
314 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.
4,075 questions
0 comments No comments
{count} votes

Your answer

Answers can be marked as Accepted Answers by the question author, which helps users to know the answer solved the author's problem.