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

Matt WilsonAsked: 2018-03-23

Who is Participating?

Experts Exchange Solution brought to you by

Enjoy your complimentary solution view.

Get every solution instantly with premium. Start your 7-day free trial.

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

LVL 14

Jamie GarrochPowerPoint Consultant & DeveloperCommented: 2018-03-23

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.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial

Matt WilsonAuthor Commented: 2018-03-23

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