Question

我想知道是否存在一个表达式，可以在PowerPoint中使用VBA将动画设置为“重复直到幻灯片结束”。我只需要一组形状即可连续执行360度旋转。这在界面中很容易做到，但是我在VBA中找不到正确的表达式。

当然，可以选择为RepeatCount和RepeatDuration设置一个较大的数字，但我只是想知道是否存在更好的方法来做到这一点。

Answer 1

在其他论坛中得到答案；你不能。重复在对象模型中未显示“直到幻灯片结束”和“直到下一次单击”。

Answer 2

使用VBA，我们无法使形状重复“直到幻灯片结束”或“直到下次单击”。

一种解决方法是复制已经创建并应用了重复动画效果的形状的动画效果。

shpOld.PickupAnimation
shpNew.ApplyAnimation

另一种方法是使Powerpoint使用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

结束功能

即使在使用第一种方法（PickUP / ApplyAnimation）之后，重复选项“直到下一次单击”也无法正常工作。幻灯片不等待单击或击键。在这种情况下，我们可以再次使用第二种方法。使用Senkeys，我们可以使效果重复“直到幻灯片结束”，然后重复“直到下一次单击”。

以下代码段是“重复直到下一次单击”动画效果的最终解决方法

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

如何设置动画重复直到VBA中的幻灯片结束

2 个答案: