如何通过VBA向一个形状添加多个动画？

Question

运行以下代码，然后开始幻灯片放映以查看以下代码的作用。

Private Sub Macro1()
    
'Delete all slides
For i = ActivePresentation.Slides.Count To 1 Step -1
    ActivePresentation.Slides(i).Delete
Next i
    
'Add a blank slide
ActivePresentation.Slides.Add index:=1, Layout:=ppLayoutBlank
    
'Add first Rectangle
With ActivePresentation.Slides(1).Shapes.AddShape(Type:=msoShapeRectangle, Left:=100, Top:=100, Width:=200, Height:=50)
    .Name = "Rectangle1"
    .TextFrame2.TextRange.Text = "Hello1"
End With
    
'Add second Rectangle
With ActivePresentation.Slides(1).Shapes.AddShape(Type:=msoShapeRectangle, Left:=100, Top:=100, Width:=200, Height:=50)
    .Name = "Rectangle2"
    .TextFrame2.TextRange.Text = "Hello2"
End With
    
'Add third Rectangle
With ActivePresentation.Slides(1).Shapes.AddShape(Type:=msoShapeRectangle, Left:=100, Top:=100, Width:=200, Height:=50)
    .Name = "Rectangle3"
    .TextFrame2.TextRange.Text = "Hello3"
End With
    
'Add animation to Rectangle1
With ActivePresentation.Slides(1).TimeLine.MainSequence.AddEffect(Shape:=ActivePresentation.Slides(1).Shapes("Rectangle1"), effectId:=msoAnimEffectStretch)
    .Timing.Duration = 2
    .Timing.TriggerDelayTime = 2
    .Timing.TriggerType = msoAnimTriggerAfterPrevious
End With
    
'Add animation to Rectangle2
With ActivePresentation.Slides(1).TimeLine.MainSequence.AddEffect(Shape:=ActivePresentation.Slides(1).Shapes("Rectangle2"), effectId:=msoAnimEffectStretch)
    .Timing.Duration = 2
    .Timing.TriggerDelayTime = 2
    .Timing.TriggerType = msoAnimTriggerAfterPrevious
End With
    
'Add animation to Rectangle3
With ActivePresentation.Slides(1).TimeLine.MainSequence.AddEffect(Shape:=ActivePresentation.Slides(1).Shapes("Rectangle3"), effectId:=msoAnimEffectStretch)
    .Timing.Duration = 2
    .Timing.TriggerDelayTime = 2
    .Timing.TriggerType = msoAnimTriggerAfterPrevious
End With

End Sub

我想减少矩形的数量。

是否可以使用一个矩形代替三个矩形？

我想要完全相同的动画结果，但我想使用一个矩形而不是三个矩形。

Answer 1

类似的东西应该有效。

Sub Macro1()

Dim slideIndex As Integer
Dim shapeIndex As Integer
Dim shapeName As String
Dim shapeText As String

'Delete all slides
For slideIndex = ActivePresentation.Slides.Count To 1 Step -1
    ActivePresentation.Slides(slideIndex).Delete
Next slideIndex

'Add a blank slide
ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutBlank

'Add Rectangles and animations
For shapeIndex = 1 To 3
    shapeName = "Rectangle" & shapeIndex
    shapeText = "Hello" & shapeIndex

    With ActivePresentation.Slides(1).Shapes.AddShape(Type:=msoShapeRectangle, Left:=100, Top:=100, Width:=200, Height:=50)
        .Name = shapeName
        .TextFrame2.TextRange.Text = shapeText
    End With

    With ActivePresentation.Slides(1).TimeLine.MainSequence.AddEffect(Shape:=ActivePresentation.Slides(1).Shapes(shapeName), effectId:=msoAnimEffectStretch)
        .Timing.Duration = 1
        .Timing.TriggerType = msoAnimTriggerAfterPrevious
    End With
Next shapeIndex

End Sub