Trigger animation delay to 2nd animation also in a shape using powerpoint vba

[dibyendu2280]

Sir I need help for simple code which I can not configure.


I have rectangular shape(say Rectangle1) with two different animations ie motion path(Right) & grow/shrink.
I want to add another rectangular shape(say Rectangle2) same as Rectangle1 with shape & animation but want to give animation delay
4 seconds to 1st animation(motion path),5 second to 2nd animation(grow/shrink).
I tried the code below it only give animation delay to motion path. But how I configure for other [2nd animation(grow/shrink)].
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 recnewShp As Shape


On Error Resume Next




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


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 recnewShp = Application.Presentations(1).Slides(1).Shapes.AddShape(shp.AutoShapeType, l, t, w, h)


recnewShp.Apply


recnewShp.ApplyAnimation


Set oeff = Application.Presentations(1).Slides(1).TimeLine.MainSequence.FindFirstAnima tionFor(recnewShp)


oeff.Timing.TriggerDelayTime = 4


oeff.Timing.TriggerType = msoAnimTriggerWithPrevious




recnewShp.Name = "Rectangle2"


Exit Sub


err:


MsgBox "Error, please select a shape."


End Sub

[John Wilson]

This seems to be a duplicate of the post here except the number of animations is different. Since the number matters please sort out which you need.
https://answers.microsoft.com/en-us/...0-2a39f587e42e

[dibyendu2280]

Thanks Sir for your attention.
I cannot configure the logic how to give animation delay to other than first animation of a shape(having 3 animation).
Sir please help to configure https://answers.microsoft.com/en-us/...0-2a39f587e42e

[John Wilson]

Thanks Sir for your attention.
I cannot configure the logic how to give animation delay to other than first animation of a shape(having 3 animation).
Sir please help to configure https://answers.microsoft.com/en-us/...0-2a39f587e42e

Try

Sub addAnnimation()
Dim oeff As Effect
Dim C As Long
Dim X As Long
Dim t As Long
Dim l As Long
Dim h As Long
Dim w As Long
Dim shp As Shape
Dim osld As Slide
Dim recnewShp As Shape
On Error Resume Next
Set osld = ActivePresentation.Slides(1)
Set shp = osld.Shapes("Rectangle 1")
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 recnewShp = osld.Shapes.AddShape(shp.AutoShapeType, l, t, w, h)
recnewShp.Apply
recnewShp.ApplyAnimation
For C = 1 To osld.TimeLine.MainSequence.Count
If osld.TimeLine.MainSequence(C).Shape.Id = recnewShp.Id Then
X = X + 1
Set oeff = osld.TimeLine.MainSequence(C)
Select Case X
Case Is = 1
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = 4
Case Is = 2
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = 5
Case Is = 3
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = 6
End Select
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
recnewShp.Name = "Rectangle 2"
End If
Next C
End Sub

Make sure the shape is named Rectangle 1.

[dibyendu2280]

Thanks Sir. Shape animation works perfectly as i wanted.
When i apply for more shape through loop it generate only one shape(ie pentagon6) but animation works perfectly.I want to generate & apply for another 15 shape. so where i do wrong?

Sub addAnnimation()
Dim oeff As Effect
Dim C As Long
Dim j As Long
Dim X As Long
Dim t As Long
Dim l As Long
Dim h As Long
Dim w As Long
Dim shp As Shape
Dim osld As Slide
Dim recnewShp As Shape
On Error Resume Next
Set osld = ActivePresentation.Slides(2)
For j = 5 To 20 'want to create 15 more shape like pentagon5 (ie pentagon6,pentagon7,......pentagon20)
Set shp = osld.Shapes("pentagon" & j)
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 recnewShp = osld.Shapes.AddShape(shp.AutoShapeType, l, t, w, h)
If shp.HasTextFrame Then
recnewShp.TextFrame.TextRange = shp.TextFrame.TextRange

End If
recnewShp.Apply
recnewShp.ApplyAnimation
For C = 1 To osld.TimeLine.MainSequence.Count
If osld.TimeLine.MainSequence(C).Shape.Id = recnewShp.Id Then
X = X + 1
Set oeff = osld.TimeLine.MainSequence(C)
Select Case X
Case Is = 1
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = (j - 4) * 4.5
Case Is = 2
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = (j - 3) * 4.5
Case Is = 3
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = (j - 3) * 4.5
Case Is = 4
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = (j - 2) * 4.5
Case Is = 5
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = (j - 1) * 4.5
End Select
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
recnewShp.Name = "pentagon" & j + 1
End If
Next C
Next j
End Sub

[John Wilson]

Yet again you have got the answer only to ask yet another different version of the question. This time I will let you work it out for yourself.

[dibyendu2280]

Sir I apologize for my mistake.
I cannot configure the animation portion of the code that's why I asking about that portion only.You configure animation portion perfectly but when I add to main code it added all shapes(shows in animation pane & selection pane) with same animation delay & displaying only one shape(ie pentagon6) with animation.
Sir please help.

[John Wilson]

Hints then


Always copy position etc from the first shape (pentagon 5?)
Set shp = osld.Shapes("pentagon 5" )

After each loop of C you need to reset X to zero I think
Next X=0
Next j

[dibyendu2280]

Thanks Sir.Now its works as I want.You are a genius & master of powerpoint vba.I have no word how to appreciate you. You save me lot of time.Thanks again sir.