Code for remembering custom animations

[StuartR]

Many years ago, on a forum that many of us subscribed to, I asked for help creating some VBA code that I needed, and someone helped me create a macro that would store all the custom animation settings of a PowerPoint slide in an array, and then reapply them after I had made changes to the slide.

I needed this because if you group, or ungroup, things on a slide it forgets the custom animation settings.

The slide I am currently dealing with has about 60 complex custom animations, many of which are dealing with identically sized objects that are behind each other in the static slide, so I REALLY need to find this code, but my searches have so far been unsuccessful.

Did anyone take a copy of this code and keep it? Does anyone know of anything that will do the job?

[HansV]

I don't have a copy of the code you mean, and I can't find anything relevant either. I experimented a bit to see if I could come up with something, but I could only reconstruct very simple animations, the code failed for anything sophisticated.
I fear there may be too little expertise here (PowerPoint VBA is very weird); you might have more luck if you posted your question in a PowerPoint forum.

[steveh]

Many years ago, on a forum that many of us subscribed to, I asked for help creating some VBA code that I needed, and someone helped me create a macro that would store all the custom animation settings of a PowerPoint slide in an array, and then reapply them after I had made changes to the slide.

Hi Stuart

Could this be it? http://bro.ws/140606L Mm I just tested the link and it only goes to the home page, this was the answer from Sam

Code: Select all

Option Explicit

Sub ListShapeNames()
' Just a debugging macro that lists all of the shape names on a slide
Dim doc As SlideRange
Dim s As Shape
Dim sr As ShapeRange
    Set doc = Activewindow.Selection.SlideRange
    Set sr = doc.Shapes.Range
    For Each s In sr
        s.Select
        MsgBox s.Name
    Next s
End Sub

Sub ListTags()
' Just a debugging macro that lists all of the tags in the selected shapes
Dim s As Shape
Dim i As Integer
    With Activewindow.Selection
        If .Type <> ppSelectionShapes Then Exit Sub
        For Each s In .ShapeRange
            For i = 1 To s.Tags.Count
                MsgBox s.Name & " is in group " & s.Tags.Item("GROUP")
            Next i
        Next s
    End With
End Sub

Sub UngroupSlide()
' This macro ungroups all of the first-level groups on a slide,
' saving the group animations in comment shapes

Dim doc As SlideRange   ' Current slide
Dim s As Shape          ' a shape on that slide
Dim sr As ShapeRange    ' All of the shapes on the current slide
Dim a As AnimationSettings
Dim ss As Shape         ' New comment shape to hold animations
    Set doc = Activewindow.Selection.SlideRange
    Set sr = doc.Shapes.Range
    For Each s In sr
        If s.Type = msoGroup Then
            Set a = s.AnimationSettings
            Set ss = doc.Shapes.AddComment
            ss.TextFrame.TextRange.Text = s.Name & " Info"
            copyAnimations s, ss
            Dissolve s      ' Ungroup & save group membership
        End If
    Next s
End Sub

Sub RegroupSlide()
Dim doc As SlideRange   ' Current slide
Dim s As Shape          ' a shape on that slide
Dim sr As ShapeRange    ' All of the shapes on the current slide
Dim grpName As String   ' Shape name of the group
Dim g As Shape          ' Regrouped shape
Dim haveGroup As Boolean    ' Set true if a shape has been regrouped
    Set doc = Activewindow.Selection.SlideRange
    Do
        haveGroup = False
        Set sr = doc.Shapes.Range
        For Each s In sr    ' Find a shape that needs regrouping
            If s.Tags("GROUP") <> "" Then
                grpName = s.Tags("GROUP")
                ClearTagsFor grpName, doc   ' Clear all the group's tags
                Set g = doc.Shapes.Range(s.Name).Regroup
                g.Name = grpName
                redoAnimations g, doc
                haveGroup = True
                Exit For            ' Start over
            End If
        Next s
    Loop While haveGroup
End Sub

Sub copyAnimations(src As Shape, dest As Shape)
' This module copies the animations from src to dest
    With dest.AnimationSettings
        If Not src.AnimationSettings.Animate Then Exit Sub
        .AdvanceMode = src.AnimationSettings.AdvanceMode
        .AdvanceTime = src.AnimationSettings.AdvanceTime
        .AfterEffect = src.AnimationSettings.AfterEffect
        .Animate = src.AnimationSettings.Animate
        .AnimateBackground = src.AnimationSettings.AnimateBackground
        .AnimateTextInReverse = src.AnimationSettings.AnimateTextInReverse
        .AnimationOrder = src.AnimationSettings.AnimationOrder
        .DimColor = src.AnimationSettings.DimColor
        .EntryEffect = src.AnimationSettings.EntryEffect
        Select Case src.AnimationSettings.SoundEffect.Type
        Case ppSoundFile
            .SoundEffect.ImportFromFile src.AnimationSettings.SoundEffect.Name
        Case Else   ' Probably won't work
            .SoundEffect.Type = src.AnimationSettings.SoundEffect.Type
        End Select
        .TextLevelEffect = src.AnimationSettings.TextLevelEffect
        .TextUnitEffect = src.AnimationSettings.TextUnitEffect
    End With
End Sub

Sub redoAnimations(grp As Shape, doc As SlideRange)
' This module searches for the comment that has the animations, copies
' the animations, and deletes the comment
Dim grpName As String
Dim s As Shape
    For Each s In doc.Shapes
        If s.Type = msoComment Then
            If s.TextFrame.TextRange.Text = grp.Name & " Info" Then
                copyAnimations s, grp
            End If
            s.Delete
            Exit Sub
        End If
    Next s
End Sub

Sub Dissolve(grp As Shape)
' This module ungroups a shape and saves the group name in a tag
Dim grpName As String
Dim sr As ShapeRange
Dim s As Shape
    grpName = grp.Name
    Set sr = grp.Ungroup
    For Each s In sr
        ClearTags s
        s.Tags.Add "Group", grpName
    Next s
End Sub

Sub ClearTags(s As Shape)
' This module clears all of the tags for a given shape
Dim i As Integer
    For i = s.Tags.Count To 1 Step -1
        s.Tags.Delete i
    Next i
End Sub

Sub ClearTagsFor(grp As String, doc As SlideRange)
' This module clears all of the tags that are part of a given group.
Dim s As Shape
    For Each s In doc.Shapes
        If s.Tags("GROUP") = grp Then ClearTags s
    Next s
End Sub

[StuartR]

...Could this be it? http://bro.ws/140606L...

FANTASTIC, thank you.

Funny how memory can deceive, I have to modify this because the problem this solves is needing to ungroup shapes so changes can be made (PowerPoint 2007 allows you to make changes to shapes that are in a group so that problem no longer exists). Today's problem is that I need to group a load of animated shapes so I can scale the whole thing up in proportion, and then ungroup them all again.

It shouldn't be too hard to modify the code though.

THANK YOU AGAIN. How did you find it?

[steveh]

Hi Stuart

I went to the lounge and in advanced seach I picked the presentation forum and used your user name and searched, from the results page I scrolled down and looked at only the topics started by you, it took about 30 seconds and I found it, I think it was page 5 and there was an example that Sam posted as well.

Glad I could help somebody out for a change instead of keep asking questions

[StuartR]

I thought it would be easy to make the modifications I want to this code, but I have a suspicion that Office 2007 may do something different with animations.

I have put a breakpoint in the code at the point where it has selected a shape. I have checked the name of the shape in the immediate window and I can see that it is a shape with an animation, but src.AnimationSettings.Animate always returns a 0

Bother.

Fortunately I have managed to create the slide I need by manual fiddling, but I shall spend more time on this later.

[steveh]

Hi Stuart

Perhaps if you find the post in the Woody's Lounge and repost with the updated amendment request Sam might see it or possibly John who is a PP MVP and used to post some good code examples.

[HansV]

You may have to use the new TimeLine object in PowerPoint 2007, but at first sight it looks just as inscrutable as the AnimationSettings object, if not more.

[John wilson]

A bit late but the code is for PP2000. From XP the animation object is completely differemt. Basically this will only work for animations that worked in 2000 ie no exits , motion paths , triggers etc

I would write it again for 2003 on but I kust use animation carbon!

[StuartR]

John,

Thank you for the original code. I guess I will have to get used to no longer being able to use it.

(Stuart goes off to search for animation carbon. Checks the price. Still trying to decide if it is worth $50)

[HansV]

Hi John,

Welcome to Eileen's Lounge!

I assume you mean Animation Carbon by Shyam Pillai.