How to set an animation repeat until end of slide in VBA

Question

I'm wondering if there is an expression for setting an animation to "Repeat Until End of Slide" using VBA in PowerPoint. I simply need a group of shapes to continually perform a 360-degree Spin. This is easy enough to do in the interface, but I can't find the correct expression for it in VBA.

Of course, there is the option to set a high number for the RepeatCount and RepeatDuration, but I was just curious if a better way existed to do this.

Answer 1

Using VBA, we can't make the shape repeat "Until end of slide" or "Until next click."

1. One Work-around is to copy the animation effect of a shape that has been already created and been applied the repeating animation effect.

   shpOld.PickupAnimation
   shpNew.ApplyAnimation

2. Another way is to make Powerpoint do the job using SendKeys:

    Function AnimationPatch(oShp)
    
        oShp.Select
        
        'Activate 'Animation Custom' Window
        If Not CommandBars.GetPressedMso("AnimationCustom") Then _
            CommandBars.ExecuteMso "AnimationCustom": WaitTimer 0.25
            
        'Set focus to the right animation window
        CommandBars("Custom Animation").Controls(1).SetFocus
        SendKeys "{PGUP}" 'select the animation effect
        WaitTimer 0.25
        'open the effect option dialog(1st time)
        CommandBars.ExecuteMso "EffectOptionsDialog"
        'or SendKeys "{ENTER}"
        
        WaitTimer 0.25
        SendKeys "+{TAB}{RIGHT}"    'goto Timing tab
        WaitTimer 0.25
        SendKeys "{TAB}{TAB}{TAB}{TAB}{DOWN}" 'repeat option'
        WaitTimer 0.25
        SendKeys "{PGDN}{PGDN}{ENTER}" 'until the end of Slide
        WaitTimer 0.25
        SendKeys "{TAB}{TAB}{ENTER}" 'Confirm
        WaitTimer 0.25
        'SendKeys "{ENTER}" 'Stop preview
        
    End Function

Even after we use the first method(PickUP/ApplyAnimation), the repeat option 'Until next click' fails to work properly. The slide doesn't wait for a click or keystroke. In this case, we can use the second method again. Using Senkeys, we can make the effect repeat 'Until end of Slide' and then 'Until next click.'

The following snippet is the final fix for the animation effect for 'repeat Until next click'

    Function WaitTimer(tick As Double)
        Dim oTimer As Double
        oTimer = Timer
        While Timer - oTimer < tick
            DoEvents
        Wend
    End Function
    
    Sub Test()
        Dim shp As Shape
        Dim sld As Slide
        Dim eft As Effect
        Dim i As Long
        
        Set sld = ActivePresentation.Slides(1)
        
        'Prepare the shape
        If sld.Shapes.Count = 0 Then
            Set shp = sld.Shapes.AddShape(msoShape10pointStar, 200, 100, 100, 100)
        Else
            Set shp = sld.Shapes(1)
        End If
        
        'remove all animation effect
        For i = sld.TimeLine.MainSequence.Count To 1 Step -1
            sld.TimeLine.MainSequence(i).Delete
        Next i
        
        'add looping animation
        Set eft = sld.TimeLine.MainSequence.AddEffect(shp, msoAnimEffectSpin, , msoAnimTriggerAfterPrevious)
        
        eft.Timing.Duration = 0.5
        'eft.Timing.RepeatCount = -2147483648#   'error
        eft.Timing.RepeatCount = 999
         
         
        'Try to apply the animation effect
        Call AnimationPatch(shp)
        
    End Sub
    
    Function AnimationPatch(oShp)
    
        oShp.Select
        
        'Activate 'Animation Custom' Window
        If Not CommandBars.GetPressedMso("AnimationCustom") Then _
            CommandBars.ExecuteMso "AnimationCustom": WaitTimer 0.25
            
        'Set focus to the right animation window
        CommandBars("Custom Animation").Controls(1).SetFocus
        SendKeys "{PGUP}" 'select the animation effect
        WaitTimer 0.25
        'open the effect option dialog(1st time)
        CommandBars.ExecuteMso "EffectOptionsDialog"
        'or SendKeys "{ENTER}"
        
        WaitTimer 0.25
        SendKeys "+{TAB}{RIGHT}"    'goto Timing tab
        WaitTimer 0.25
        SendKeys "{TAB}{TAB}{TAB}{TAB}{DOWN}" 'repeat option'
        WaitTimer 0.25
        SendKeys "{PGDN}{PGDN}{ENTER}" 'until the end of Slide
        WaitTimer 0.25
        SendKeys "{TAB}{TAB}{ENTER}" 'Confirm
        WaitTimer 0.25
        'SendKeys "{ENTER}" 'Stop preview
        'WaitTimer 0.25
    
        '// or Set the repeat option to 'until next click'
        'Set focus to the right animation window
        CommandBars("Custom Animation").Controls(1).SetFocus
        WaitTimer 0.25
        'select the first animation effect / if the shape has only one effect, you can skip this.
        SendKeys "{PGUP}"
        WaitTimer 0.25
        'open the effect option dialog (2nd time)
        SendKeys "{ENTER}"      '//CommandBars.ExecuteMso "EffectOptionsDialog"
        WaitTimer 0.25
        SendKeys "+{TAB}{RIGHT}"    'Timing tab
        WaitTimer 0.25
        SendKeys "{TAB}{TAB}{TAB}{TAB}{DOWN}" 'repeat option
        WaitTimer 0.25
        SendKeys "{PGDN}{UP}{ENTER}" 'until the next click
        WaitTimer 0.25
        SendKeys "{TAB}{TAB}{ENTER}" 'confirm
        WaitTimer 0.25
        SendKeys "{ENTER}" 'Stop preview
        WaitTimer 0.25
            
    End Function

Answer 2

Got an answer in a different forum; you can't. Repeat "Until end of slide" and "Until next click" are not exposed in the object model.