Copying animation and sequence information between powerpoint shapes - vba

Question

I'm trying to replace all shape objects on the slide (pictures) with shape objects of another type (rectangular shape). I can delete old object and create new, but i will loose all animation information and sequence order. Is it possible to store animation information and order in timeline, and copy it to the new shape object?

Answer 1

Well, i have found a solution myself, hope someone could find it useful. So, it is not necessary to copy animation information from old shape to a new one, just cycle through sequence's items and replace the shape object refrence to the new shape. Like this:
On Error Resume Next
Dim shp1 As Shape 'old shape
Set shp1 = ActivePresentation.Slides(1).Shapes(3)
Dim shp2 As Shape 'new shape
Set shp2 = ActivePresentation.Slides(1).Shapes.AddPicture("c:\imgres2.jpg", msoFalse, msoTrue, 0, 0) 'it is important to create new shape before cycling through existing ones.
For i = ActivePresentation.Slides(1).TimeLine.MainSequence.count To 1 Step -1
'using "is" opeartor to compare refrences
If shp1 Is ActivePresentation.Slides(1).TimeLine.MainSequence.Item(i).Shape Then
ActivePresentation.Slides(1).TimeLine.MainSequence.Item(i).Shape = shp2
End If
Next i
shp1.Delete 'delete the old shape

Answer 2

Try something like this code to copy the animation into new added shape:
Sub PasteAnimationBehaviours()
Dim SHP As Shape 'for existing shape
Set SHP = ActivePresentation.Slides(1).Shapes(1)
SHP.PickupAnimation
Dim newSHP As Shape 'pasting to new shape
Set newSHP = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 100, 100, 100, 100)
newSHP.ApplyAnimation
End Sub
Added after comment: If you only need to replace type of shape try to use something like this:
Sub ShapeSubstition()
Dim SHP As Shape 'for existing shape
'test for 1st shape in 1st slide
Set SHP = ActivePresentation.Slides(1).Shapes(1)
SHP.AutoShapeType = msoShapeRectangle 'to rectangle
SHP.AutoShapeType = msoShapeOval 'to oval
End Sub

Answer 3

I think it is probably easier to just use the "Animation Painter" command button to copy the animations and apply them to another object. The Animation Painter functions in the same way as the Format Painter. After you have copied the desired animations, you can reorder the individual animations using the Animation Pane.

Answer 4

This code shows how to copy effects from one shape to another. Select a shape before running routine "SetSourceShape" and select one or more shapes before running "PaintEffects".
Option Explicit
' resources:
' http://msdn.microsoft.com/en-us/library/aa168134(v=office.11).aspx
' http://msdn.microsoft.com/en-us/library/aa168135(office.11).aspx
' http://skp.mvps.org/ppttimeline1.htm
' uses functions from:
' https://answers.microsoft.com/en-us/msoffice/forum/all/how-to-copy-paste-animation-effect-in-powerpoint/c0f255c0-167a-4a12-ae37-1e713ee1d8df
Public MySourceShapeId As Long
Public MySourceSlideIndex As Long ' need this with shape id for unique selection
Sub SetSourceShape() ' sets source shape id value if successfull
Dim oShp As PowerPoint.Shape
Dim myShp As PowerPoint.Shape
Dim oSld As Slide
Dim oEffect As Effect
Dim HowMany As Long
Dim FoundEffect As Boolean
HowMany = 0 ' default value for nothing selected
MySourceShapeId = 0 ' default value for nothing available to copy
MySourceSlideIndex = 0
FoundEffect = False ' default value unless selected shape has any effect(s)
On Error Resume Next ' handles error when nothing is selected
HowMany = ActiveWindow.Selection.ShapeRange.Count
On Error GoTo 0 ' restore normal error handling
If HowMany = 0 Then
MsgBox "Nothing is selected"
Else
If HowMany = 1 Then
Set oShp = ActiveWindow.Selection.ShapeRange(1) ' selection on a single slide
For Each oEffect In ActiveWindow.Selection.SlideRange(1).TimeLine.MainSequence
If oEffect.Shape.Id = oShp.Id Then
MySourceShapeId = oShp.Id
MySourceSlideIndex = ActiveWindow.Selection.SlideRange(1).SlideIndex
FoundEffect = True
End If
Next
If FoundEffect Then
MsgBox "Source is selected, Slide: " & MySourceSlideIndex & ", ShapeID: " & MySourceShapeId
Else
MsgBox "Selected item has no effect(s)"
End If
Else
MsgBox "Select only one item"
End If
End If
End Sub
Sub PaintEffects()
Dim oShp As PowerPoint.Shape
Dim oEffect As Effect
Dim HowMany As Long
Dim msg As String
HowMany = 0 ' default value for nothing selected
If MySourceShapeId = 0 Then
MsgBox "No source is selected"
Exit Sub
End If
On Error Resume Next ' handles error when nothing is selected
HowMany = ActiveWindow.Selection.ShapeRange.Count
On Error GoTo 0 ' restore normal error handling
If HowMany = 0 Then
MsgBox "Nothing is selected to paint"
Else
' make sure source is not in this selection
If ActiveWindow.Selection.SlideRange(1).SlideIndex = MySourceSlideIndex Then ' check shapes
For Each oShp In ActiveWindow.Selection.ShapeRange
If oShp.Id = MySourceShapeId Then ' complain
MsgBox "Target selection must not include source item"
Exit Sub
End If
Next
End If
' OK, proceed
For Each oShp In ActiveWindow.Selection.ShapeRange
For Each oEffect In ActivePresentation.Slides(MySourceSlideIndex).TimeLine.MainSequence
If oEffect.Shape.Id = MySourceShapeId Then
Call TransferEffects(oEffect, ActiveWindow.Selection.SlideRange(1), oShp)
End If
Next
Next
End If
End Sub
Sub TransferEffects(oEffectA As PowerPoint.Effect, oSlide As Slide, oShape As PowerPoint.Shape)
Dim oEffectB As Effect
Dim IsMotion As Boolean
Set oEffectB = oSlide.TimeLine.MainSequence.AddEffect(oShape, oEffectA.EffectType)
DoEvents
On Error Resume Next
oEffectB.EffectParameters.Amount = oEffectA.EffectParameters.Amount
If Err.Number = 0 Then
Select Case oEffectA.EffectParameters.Color2.Type
Case Is = msoColorTypeScheme
oEffectB.EffectParameters.Color2.SchemeColor = oEffectA.EffectParameters.Color2.SchemeColor
Case Is = msoColorTypeRGB
oEffectB.EffectParameters.Color2.RGB = oEffectA.EffectParameters.Color2.RGB
End Select
End If
oEffectB.EffectParameters.Direction = oEffectA.EffectParameters.Direction
oEffectB.EffectParameters.FontName = oEffectA.EffectParameters.FontName
If oEffectA.EffectType <> msoAnimEffectGrowShrink Then
oEffectB.EffectParameters.Size = oEffectA.EffectParameters.Size
Else
oEffectB.Behaviors(1).ScaleEffect.ByX = oEffectA.Behaviors(1).ScaleEffect.ByX
oEffectB.Behaviors(1).ScaleEffect.ByY = oEffectA.Behaviors(1).ScaleEffect.ByY
End If
oEffectB.Timing.Duration = oEffectA.Timing.Duration
oEffectB.Timing.Accelerate = oEffectA.Timing.Accelerate
oEffectB.Timing.AutoReverse = oEffectA.Timing.AutoReverse
oEffectB.Timing.Decelerate = oEffectA.Timing.Decelerate
oEffectB.Timing.Restart = oEffectA.Timing.Restart
oEffectB.Timing.RewindAtEnd = oEffectA.Timing.RewindAtEnd
oEffectB.Timing.SmoothStart = oEffectA.Timing.SmoothStart
oEffectB.Timing.SmoothEnd = oEffectA.Timing.SmoothEnd
oEffectB.Exit = oEffectA.Exit
oEffectB.Timing.TriggerType = oEffectA.Timing.TriggerType
oEffectB.Timing.TriggerDelayTime = oEffectA.Timing.TriggerDelayTime
oEffectB.Timing.RepeatCount = oEffectA.Timing.RepeatCount
oEffectB.Timing.RepeatDuration = oEffectA.Timing.RepeatDuration
oEffectB.Timing.Speed = oEffectA.Timing.Speed
With oSlide.TimeLine.MainSequence
If oEffectA.Shape.HasTextFrame Then
Call .ConvertToAnimateBackground(oEffectB, oEffectA.EffectInformation.AnimateBackground)
Else
Call .ConvertToAnimateBackground(oEffectB, True)
End If
Select Case oEffectA.EffectInformation.AfterEffect
Case 2 ' Hide
Call .ConvertToAfterEffect(oEffectB, oEffectA.EffectInformation.AfterEffect)
Case 1 ' Dim
Call .ConvertToAfterEffect(oEffectB, oEffectA.EffectInformation.AfterEffect, oEffectA.EffectInformation.Dim)
Case 3 ' Hide on click
Call .ConvertToAfterEffect(oEffectB, oEffectA.EffectInformation.AfterEffect)
End Select
Call .ConvertToAnimateInReverse(oEffectB, oEffectA.EffectInformation.AnimateTextInReverse)
Call .ConvertToTextUnitEffect(oEffectB, oEffectA.EffectInformation.TextUnitEffect)
End With
Err.Clear
oEffectB.EffectParameters.Relative = oEffectA.EffectParameters.Relative
If Err.Number <> 0 Then
IsMotion = False
Else
IsMotion = True
End If
If IsMotion Then
oEffectB.Behaviors(1).MotionEffect.Path = oEffectA.Behaviors(1).MotionEffect.Path
On Error GoTo 0
If Sgn(Val(oEffectA.Behaviors(1).Timing.Speed)) = -1 Then
oEffectB.Behaviors(1).MotionEffect.Path = Left(oEffectA.Behaviors(1).MotionEffect.Path, 1) & " " & ReversePathInfo(Trim(Mid(oEffectA.Behaviors(1).MotionEffect.Path, 2)))
End If
End If
Exit Sub
errHandler:
If MsgBox(Err.Number & " " & Err.Description & vbCrLf & "Do you wish to continue?", vbQuestion + vbYesNo, "APP_NAME") = vbYes Then
Resume Next
End If
End Sub
Function ReversePathInfo(sPath As String) As String
Dim sItems() As String
Dim i As Integer
Dim sPositions() As String
Dim sReversedPath As String
Dim sClosedPath As String
If Not IsNumeric(Right(sPath, 1)) Then
sClosedPath = Right(sPath, 1)
sPath = Left(sPath, Len(sPath) - 1)
End If
sPath = Replace(sPath, " ", "~")
sItems = Split(sPath, "~")
ReDim sPositions(0 To UBound(sItems))
For i = LBound(sItems) To UBound(sItems)
If Left(sItems(i), 1) = "L" Then sPositions(i) = "L"
If Left(sItems(i), 1) = "C" Then sPositions(i) = "C"
If Left(sItems(i), 1) = "c" Then sPositions(i) = "c"
If Left(sItems(i), 1) = "l" Then sPositions(i) = "l"
Next i
For i = LBound(sPositions) To UBound(sPositions)
If LCase(sPositions(i)) = "c" Then
sPositions(i + 2) = sPositions(i)
sPositions(i) = ""
i = i + 2
End If
Next i
For i = UBound(sItems) To LBound(sItems) Step -1
Select Case Left(sItems(i), 1)
Case "L", "C", "c", "l"
sItems(i) = Trim(Mid(sItems(i), 2))
End Select
sReversedPath = sReversedPath & sItems(i) & " " & sPositions(i) & IIf(sPositions(i) <> "", " ", "")
Next i
ReversePathInfo = Trim(sReversedPath) & IIf(sClosedPath = "", "", " " & sClosedPath)
End Function