PowerPoint 2007 VBA Macro for Expanding Custom Animation into Multiple Slides (for Export to .PDF)

When I make presentation slides, I like using a lot of diagrams to explain algorithms, and often I use animations to show the different processing stages of these algorithms. In the past, I would just make a different slide for each stage in an animation sequence, but this gets tedious when I have to make lots of edits to a slide (I then have to go back and change all the slides in the animation sequence). So I started using the custom animation feature of PowerPoint, but when PowerPoint exports a presentation or prints notes, it sticks all of the animation elements on a single slide, so it's not possible to follow the animations in an exported presentation. This is especially important when exporting to PDF so that I can put my presentation online or so that I can have a backup copy of the presentation around in case there are portability problems with PowerPoint.

There were a couple of scripts online for doing this (here and here), but I wanted to write my own because one of them came with an installer, which I don't like, and the other one seemed too limited. Figuring out how to write my script ended up being more difficult than I expected though. I've programmed a few things in Visual Basic for Applications (VBA) before--the standard way to write macros for Office--but I vaguely remembered that when designing Office 2007, Microsoft said that it would be phasing out VBA in subsequent versions in preference for Visual Studio .Net. In fact, the record VBA macro feature (a common technique people use to program initial macros) wasn't even included in PowerPoint 2007. Programming things in .Net is a bit of overkill when you just want to write a little macro that's easy to distribute, so that wasn't feasible either. I thought about writing a little VBScript or JavaScript/JScript script that would do what I wanted, but then I found out that Microsoft was deprecating the whole ActiveScripting framework as well. Since the new Office file format OOXML is supposedly XML, I thought about just reading in and modifying the files directly, but after playing with the files a bit, I found that OOXML is very much an XML dump of the legacy Office file formats. There are all sorts of crazy cross-links between the different sub-files inside an OOXML zip file that it's impossible to read and modify a small part of the file without breaking it. In order to modify it properly, you really need to read and parse the whole thing into an intermediate form, modify it there, and then write a new file from scratch, but this is clearly too much work for a little script. I briefly considered making my presentation in OpenOffice instead, and I actually would have if the OpenOffice people had bothered to add in a couple of extra features into their application instead of simply making a brain-dead clone of Office (e.g. like being able to animate the color changes of individual words of text instead of being restricted to paragraphs only), but I was beginning to like the automatic text sizing and animation number indicators of PowerPoint 2007.

After much digging around though, I found out that Microsoft had changed their mind and decided not to deprecate VBA after all. Starting with Office 14 / Office 2010, Microsoft has renewed their commitment to maintaining VBA. So I wrote a little VBA script to split up an animation into multiple slides. I believe my script handles all entrance and exit animations, but I haven't really tested this. It makes use of Office 2007's new API for exposing the different sub-parts of an animation, which should allow a script to handle new animations in a more uniform way. Unfortunately, this new API is still somewhat broken, so it needs various error-handling code to handle anomalies like SetEffect objects without any properties etc.

To use the script, go into PowerPoint 2007, go to View...Macros, create a new macro called "ExpandAnimations", replace the macro code with the code below, and then run it.

Private AnimVisibilityTag As String


Sub ExpandAnimations()
AnimVisibilityTag = "AnimationExpandVisibility"

Dim pres As Presentation
Dim Slidenum As Integer

Set pres = ActivePresentation
Slidenum = 1
Do While Slidenum <= pres.Slides.Count
Dim s As Slide
Dim animationCount As Integer
Set s = pres.Slides.Item(Slidenum)

If s.TimeLine.MainSequence.Count > 0 Then
    Set s = pres.Slides.Item(Slidenum)
    PrepareSlideForAnimationExpansion s
    animationCount = expandAnimationsForSlide(pres, s)
Else
    animationCount = 1
End If
Slidenum = Slidenum + animationCount
Loop
End Sub

Private Sub PrepareSlideForAnimationExpansion(s As Slide)
' Set visibility tags on all shapes
For Each oShape In s.Shapes
oShape.Tags.Add AnimVisibilityTag, "true"
Next oShape

' Find initial visibility of each shape
For animIdx = s.TimeLine.MainSequence.Count To 1 Step -1
Dim seq As Effect
Set seq = s.TimeLine.MainSequence.Item(animIdx)
On Error GoTo UnknownEffect
For behaviourIdx = seq.Behaviors.Count To 1 Step -1
    Dim behavior As AnimationBehavior
    Set behavior = seq.Behaviors.Item(behaviourIdx)
    If behavior.Type = msoAnimTypeSet Then
        If behavior.SetEffect.Property = msoAnimVisibility Then
            If behavior.SetEffect.To <> 0 Then
                seq.Shape.Tags.Delete AnimVisibilityTag
                seq.Shape.Tags.Add AnimVisibilityTag, "false"
            Else
                seq.Shape.Tags.Delete AnimVisibilityTag
                seq.Shape.Tags.Add AnimVisibilityTag, "true"
            End If
        End If
    End If
Next behaviourIdx
NextSequence:
On Error GoTo 0
Next animIdx
Exit Sub

UnknownEffect:
MsgBox ("Encountered an error while calculating object visibility: " + Err.Description)
Resume NextSequence
End Sub


Private Function expandAnimationsForSlide(pres As Presentation, s As Slide) As Integer
Dim numSlides As Integer
numSlides = 1

' Play the animation back to determine visibility
Do While True
' Stop when animation is over or we hit a click trigger
If s.TimeLine.MainSequence.Count <= 0 Then Exit Do
Dim fx As Effect
Set fx = s.TimeLine.MainSequence.Item(1)
If fx.Timing.TriggerType = msoAnimTriggerOnPageClick Then Exit Do

' Play the animation
PlayAnimationEffect fx
fx.Delete
Loop

' Make a copy of the slide and recurse
If s.TimeLine.MainSequence.Count > 0 Then
s.TimeLine.MainSequence.Item(1).Timing.TriggerType = msoAnimTriggerWithPrevious
Dim nextSlide As Slide
Set nextSlide = s.Duplicate.Item(1)
numSlides = 1 + expandAnimationsForSlide(pres, nextSlide)
End If

' Apply visibility
rescan = True
While rescan
rescan = False
For n = 1 To s.Shapes.Count
    If s.Shapes.Item(n).Tags.Item(AnimVisibilityTag) = "false" Then
        s.Shapes.Item(n).Delete
        rescan = True
        Exit For
    End If
Next n
Wend

' Clear all tags
For Each oShape In s.Shapes
oShape.Tags.Delete AnimVisibilityTag
Next oShape

' Remove animation (since they've been expanded now)
While s.TimeLine.MainSequence.Count > 0
s.TimeLine.MainSequence.Item(1).Delete
Wend

expandAnimationsForSlide = numSlides
End Function


Private Sub assignColor(ByRef varColor As ColorFormat, valueColor As ColorFormat)
If valueColor.Type = msoColorTypeScheme Then
varColor.SchemeColor = valueColor.SchemeColor
Else
varColor.RGB = valueColor.RGB
End If
End Sub


Private Sub PlayAnimationEffect(fx As Effect)
On Error GoTo UnknownEffect
For n = 1 To fx.Behaviors.Count
Dim behavior As AnimationBehavior
Set behavior = fx.Behaviors.Item(n)
Select Case behavior.Type
    Case msoAnimTypeSet
        ' Appear or disappear
        If behavior.SetEffect.Property = msoAnimVisibility Then
            If behavior.SetEffect.To <> 0 Then
                fx.Shape.Tags.Delete AnimVisibilityTag
                fx.Shape.Tags.Add AnimVisibilityTag, "true"
            Else
                fx.Shape.Tags.Delete AnimVisibilityTag
                fx.Shape.Tags.Add AnimVisibilityTag, "false"
            End If
        Else
            ' Log the problem
        End If
    Case msoAnimTypeColor
        ' Change color
        If fx.Shape.HasTextFrame Then
            Dim range As TextRange
            Set range = fx.Shape.TextFrame.TextRange
            assignColor range.Paragraphs(fx.Paragraph).Font.Color, behavior.ColorEffect.To
        End If


    Case Else
        ' Log the problem
End Select
Next n
Exit Sub
UnknownEffect:
MsgBox ("Encountered an error expanding animations: " + Err.Description)
Exit Sub
End Sub