How can I force the Animation Painter to paste in VBA?

In PowerPoint VBA, I'm trying to use the Animation Painter to copy the animation from one picture to the other pictures on a slide. My code successfully turns on the Animation Painter and it successfully selects the next picture, but I can't actually get the paste to work. If I pause execution right after the Animation painter is turned on then I can manually select the next the picture and the animation is successfully copied. So how do I force the paste? Here is the code:

Sub animaPainter()

Dim osh As Shape
Dim nameSelect As String

nameSelect = ActiveWindow.Selection.ShapeRange.Name

For Each osh In ActiveWindow.Selection.SlideRange.Shapes

With osh
If osh.Name = nameSelect Then GoTo LoopEnd
If .Type = msoLinkedPicture _
Or .Type = msoPicture _
Then
togglePainter
osh.Select msoTrue
osh.Apply

End If
End With
LoopEnd:

Next

End Sub

Private Sub togglePainter()

Dim localApp As PowerPoint.Application
Set localApp = GetObject(Class:="PowerPoint.Application")
localApp.CommandBars.ExecuteMso ("AnimationPainter")

End Sub

You can pickup the animation from one shape to another as follows:

With ActiveWindow.Selection
  .ShapeRange(1).PickupAnimation
  .ShapeRange(2).ApplyAnimation
End With

Open in new window

The Apply method you're using is for the Format painter tool.

Thanks a lot. That worked like a charm. And much easier than my method. Below is the final code to make this thing work.

Sub animaPainter()

Dim osh As Shape
Dim nameSelect As String

nameSelect = ActiveWindow.Selection.ShapeRange.Name
ActiveWindow.Selection.ShapeRange(nameSelect).PickupAnimation

For Each osh In ActiveWindow.Selection.SlideRange.Shapes

With osh
If osh.Name = nameSelect Then GoTo LoopEnd
If .Type = msoLinkedPicture _
Or .Type = msoPicture _
Then
osh.ApplyAnimation
End If
End With
LoopEnd:

Next

End Sub

You're welcome Matt! Glad it worked for you.

How can I force the Animation Painter to paste in VBA?

Premium Content

Premium Content