How to trigger animation delay in PowerPoint using VBA

Question

I think its a simple question but I can not configure out.

I have a rectangular shape with (motionpath>line curve>left) animation(ie, Rectangle1 animate from right to left side in horizontal straight line).

My requirement is (1) Add another same rectangular shape ie Rectangle2

(2) Add same animation & give some animation delay(say 5) & start with previous(ie trigger).

I can not configure effectId: in AddEffect porion.When I use effectId:=msoAnimEffectCustom its not animate.

If I remove

"Set oeff = Application.Presentations(1).Slides(1).TimeLine.MainSequence.AddEffect _

(Shape:=newShp, effectId:=msoAnimEffectCustom, trigger:=msoAnimTriggerAfterPrevious)

oeff.Timing.TriggerDelayTime = 5"

its animate exactly how i wanted but without animation delay & start with previous(ie trigger).Any other solution 

will be equally appreciated.Thanks.

I tried

Sub addAnnimation()

Dim oeff As Effect

Dim shp As Shape

Dim newShp As Shape

Set shp = Application.Presentations(1).Slides(1).Shapes("Rectangle1")

shp.PickupAnimation

'Capture properties of exisitng Rectangle1 such as location and size

With shp

t = .Top

l = .Left

h = .Height

w = .Width

End With

Set newShp = Application.Presentations(1).Slides(1).Shapes.AddShape(msoShapeRectangle, l, t, w, h)

newShp.ApplyAnimation

newShp.Name = "RectangleTop2"

Set oeff = Application.Presentations(1).Slides(1).TimeLine.MainSequence.AddEffect _

(Shape:=newShp, effectId:=msoAnimEffectCustom, trigger:=msoAnimTriggerAfterPrevious)

oeff.Timing.TriggerDelayTime = 5

End Sub

Answer 1

This should do it >> NOTE the first shape MUST be selected.

Sub addAnnimation()

 Dim oeff As Effect

 Dim t As Long

 Dim l As Long

 Dim h As Long

 Dim w As Long

 Dim shp As Shape

 Dim newShp As Shape

 On Error Resume Next

Set shp = ActiveWindow.Selection.ShapeRange(1)

If shp Is Nothing Then GoTo err

shp.PickupAnimation

shp.PickUp

'Capture properties of exisitng Rectangle1 such as location and size

With shp

    t = .Top

    l = .Left

    h = .Height

    w = .Width

End With

Set newShp = Application.Presentations(1).Slides(1).Shapes.AddShape(shp.AutoShapeType, l, t, w, h)

If newShp.HasTextFrame Then

newShp.TextFrame.TextRange = shp.TextFrame.TextRange

End If

newShp.Apply

newShp.ApplyAnimation

Set oeff = Application.Presentations(1).Slides(1).TimeLine.MainSequence.FindFirstAnimationFor(newShp)

    oeff.Timing.TriggerDelayTime = 5

    oeff.Timing.TriggerType = msoAnimTriggerWithPrevious

Exit Sub

err:

    MsgBox "Error, please select a shape."

End Sub

Answer 2

maybe

Sub addAnnimation()

 Dim oeff As Effect

 Dim t As Long

 Dim l As Long

 Dim h As Long

 Dim w As Long

 Dim shp As Shape

 Dim newShp As Shape

Set shp = Application.Presentations(1).Slides(1).Shapes("Rectangle1")

shp.PickupAnimation

'Capture properties of exisitng Rectangle1 such as location and size

With shp

    t = .Top

    l = .Left

    h = .Height

    w = .Width

End With

Set newShp = Application.Presentations(1).Slides(1).Shapes.AddShape(msoShapeRectangle, l, t, w, h)

newShp.ApplyAnimation

Set oeff = Application.Presentations(1).Slides(1).TimeLine.MainSequence.FindFirstAnimationFor(newShp)

    oeff.Timing.TriggerDelayTime = 5

    oeff.Timing.TriggerType = msoAnimTriggerWithPrevious

End Sub

Answer 3

Thanks @John SR Wilson

Its works absolutely fine.You save me lot of time.

Sir,I want your little help to configure above code such that

(1) it copy everything of the first object (ie colour and text within shape also).

In above code colour & text within shape not copied.

Want to exactly duplicate shape(ie any custom shape,pentagon & text within shape)

(2)For custom shape how to write this line

Set newShp = Application.Presentations(1).Slides(1).Shapes.AddShape(msoShapeRectangle, l, t, w, h)

Any other solution will be equally appreciated.Thanks Sir.

Answer 4

Thanks @John SR Wilson

Sorry for the late reply.

You are a genius & master of PowerPoint VBA.

Above script working fine in a shape which have single animation(after applied trigger delay time).

In my case one shape(a pentagon) have animations in such a manner:

(1)motion path(Left)

(2)grow/shrink(Emphasis)

(3)fill color(Emphasis)

(4)grow/shrink(Emphasis)

(5)grow/shrink(Emphasis)

I copied a pentagonal shape having animations exactly in my project as below

(1)motion path(Left):    Start: 40.5s End: 01:03.5s

(2)grow/shrink(Emphasis):     Start: 45s End: 46s

(3)fill color(Emphasis):           Start: 45s End: Next slide

(4)grow/shrink(Emphasis):     Start: 49.5s End: 50.5s

(5)grow/shrink(Emphasis):     Start: 54s End: 55s

Want to add an other pentagonal shape & give same animation(as above mention) but start 4.5s after the start of previous copied pentagon. so I give 

oeff.Timing.TriggerDelayTime =45

    in above code & new pentagon shape added with below animation

(1)motion path(Left):    Start: 45s End: 01:08s

(2)grow/shrink(Emphasis):     Start: 45s End: 46s

(3)fill color(Emphasis):           Start: 45s End: Next slide

(4)grow/shrink(Emphasis):     Start: 49.5s End: 50.5s

(5)grow/shrink(Emphasis):     Start: 54s End: 55s

TriggerDelayTime   applied only in motion path(Left) animation.

Remaining (2)grow/shrink(Emphasis),(3)fill color(Emphasis),(4)grow/shrink(Emphasis),(5)grow/shrink(Emphasis) not applied TriggerDelayTime.

Final result  will be like below(animation delay between two shapes 4.5s)

(1)motion path(Left):    Start: 45s End: 01:08s

(2)grow/shrink(Emphasis):     Start: 49.5s End: 50.5s

(3)fill color(Emphasis):           Start: 49.5s End: Next slide

(4)grow/shrink(Emphasis):     Start: 54s End: 55s

(5)grow/shrink(Emphasis):     Start: 58.5s End: 59.5s

Any other solution will be equally appreciated.Thanks again Sir.