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

' 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