OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy Bookmark and Share

Replicate animation from one slide to another identical slide

PowerPoint 2010 introduced two new methods for copying and transfering animations to another shape. We will use that to transfer animation from one slide to another identical slide. The follow assumptions are made. Both slides are identical, have shapes with the same names and the target slide has no previously assigned animations.

Supported versions: PowerPoint 2010+


' --------------------------------------------------------------------------------

' Copyright ©1999-2022, Shyam Pillai, All Rights Reserved.

' --------------------------------------------------------------------------------

' You are free to use this code within your own applications, add-ins,

' documents etc but you are expressly forbidden from selling or 

' otherwise distributing this source code without prior consent.

' This includes both posting free demo projects made from this

' code as well as reproducing the code in text or html format.

' --------------------------------------------------------------------------------
Sub Test()

Call TransferAnimation(ActivePresentation.Slides(1), ActivePresentation.Slides(2))

End Sub

 

Sub TransferAnimation(sourceSlide As Slide, targetSlide As Slide)

Dim sourceShape As Shape

Dim targetShape As Shape

Dim eft As Effect

Dim I As Integer

Dim col As New Collection

On Error Resume Next

' Multiple references not needed so use a collection to get only one reference of the shape with multiple animations
For I = 1 To sourceSlide.TimeLine.MainSequence.Count

    With sourceSlide.TimeLine.MainSequence(I)

        col.Add .Shape.Name, .Shape.Name

    End With

Next
'Apply the animation to the shapes on the french slide
For I = 1 To col.Count

   Set sourceShape = sourceSlide.Shapes(col(I))

   sourceShape.PickupAnimation

   Set targetShape = targetSlide.Shapes(col(I))

   targetShape.ApplyAnimation

Next

'Remap the animation to match source slide
For I = sourceSlide.TimeLine.MainSequence.Count To 1 Step -1

   With sourceSlide.TimeLine.MainSequence(I)

       Set eft = GetEffect(targetSlide, .Shape.Name, I)

       If Not eft Is Nothing Then

           eft.MoveTo I

       End If

   End With

Next

End Sub

 

Function GetEffect(sld As Slide, shapeName As String, startPosition As Integer) As Effect

Dim I As Integer

For I = startPosition To 1 Step -1

    With sld.TimeLine.MainSequence(I)

        If .Shape.Name = shapeName Then

            Set GetEffect = sld.TimeLine.MainSequence(I)

            Exit Function

        End If

    End With

Next

End Function
 
 


Copyright 1999-2022 (c) Shyam Pillai. All rights reserved.