如何为一个形状添加多个动画？

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 = 1
        .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 = 1
        .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 = 1
        .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