将设置有演示动画的PPT转换为有动画的PDF文件

 目的：将设置有演示动画的PPT转换为有动画的PDF文件

 

 方法一：1. 打开PPT  2.视图   3.宏  4.创建新的宏文件

 

 

 

5.复制代码（将原本的两行代码删除，复制新的进去）  6.重回PPT主页中点击 宏  7.点击addElements后点击运行 ，即可看到PPT页面中多出许多自动生成的页数  8.这时将PPT保存文件为PDF形式--done, 对于原来的PPT文件可关闭保存不做修改，也可点击remElements后点击运行然后多出的页数就会自动消失，这时再保存

 

 

要复制进去的代码：

Option Explicit

Sub AddElements()
Dim shp As Shape

Dim i As Integer, n As Integer
n = ActivePresentation.Slides.Count
For i = 1 To n
    Dim s As Slide
    Set s = ActivePresentation.Slides(i)
    s.SlideShowTransition.Hidden = msoTrue
    
    Dim max As Integer: max = AnimationElements(s)
    Dim k As Integer, s2 As Slide
    For k = 1 To max
        Set s2 = s.Duplicate(1)
        s2.Name = "AutoGenerated: " & s2.SlideID
        s2.SlideShowTransition.Hidden = msoFalse
        s2.MoveTo ActivePresentation.Slides.Count
        
        Dim i2 As Integer, h As Shape
        Dim Del As New Collection
        For i2 = s2.Shapes.Count To 1 Step -1
            Set h = s2.Shapes(i2)
            If Not IsVisible(s2, h, k) Then Del.Add h
        Next
        Dim j As Integer
        For j = s.TimeLine.MainSequence.Count To 1 Step -1
            s2.TimeLine.MainSequence.Item(1).Delete
        Next
        For j = Del.Count To 1 Step -1
            Del(j).Delete
            Del.Remove j
        Next
    Next
Next
End Sub

'is the shape on this slide visible at point this time step (1..n)
Function IsVisible(s As Slide, h As Shape, i As Integer) As Boolean

'first search for a start state
Dim e As Effect
IsVisible = True
For Each e In s.TimeLine.MainSequence
    If e.Shape Is h Then
        IsVisible = Not (e.Exit = msoFalse)
        Exit For
    End If
Next

'now run forward animating it
Dim n As Integer: n = 1
For Each e In s.TimeLine.MainSequence
    If e.Timing.TriggerType = msoAnimTriggerOnPageClick Then n = n + 1
    If n > i Then Exit For
    If e.Shape Is h Then IsVisible = (e.Exit = msoFalse)
Next
End Function

'How many animation steps are there
'1 for a slide with no additional elements
Function AnimationElements(s As Slide) As Integer
AnimationElements = 1
Dim e As Effect
For Each e In s.TimeLine.MainSequence
    If e.Timing.TriggerType = msoAnimTriggerOnPageClick Then
        AnimationElements = AnimationElements + 1
    End If
Next
End Function

Sub RemElements()
Dim i As Integer, n As Integer
Dim s As Slide
n = ActivePresentation.Slides.Count
For i = n To 1 Step -1
    Set s = ActivePresentation.Slides(i)
    If s.SlideShowTransition.Hidden = msoTrue Then
        s.SlideShowTransition.Hidden = msoFalse
    ElseIf Left$(s.Name, 13) = "AutoGenerated" Then
        s.Delete
    End If
Next
End Sub

　　

 

方法二：操作步骤同上，代码只不过进行了改进，因为上述方法做出的PDF比实际页数要多，多出的是自动生成的页数，（对于如果要添加页脚标注的话，则会出现与实际不符的情况，对于无页脚页数标注的情况则没影响），对于有页脚标注页数要求的则可以采用的二种方法；

对应的代码：

Option Explicit

Sub AddElements()
Dim shp As Shape

Dim i As Integer, n As Integer
n = ActivePresentation.Slides.Count
For i = 1 To n
    Dim s As Slide
    Set s = ActivePresentation.Slides(i)
    s.SlideShowTransition.Hidden = msoTrue
    
    Dim max As Integer: max = AnimationElements(s)
    Dim k As Integer, s2 As Slide
    For k = 1 To max
        Set s2 = s.Duplicate(1)
        s2.Name = "AutoGenerated: " & s2.SlideID
        s2.SlideShowTransition.Hidden = msoFalse
        
        Dim oshp As Shape
        With s2.Shapes
            Set oshp = .AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 50)
            oshp.TextFrame.TextRange.Font.Name = "Arial"
            oshp.TextFrame.TextRange.Font.Size = 12
            oshp.TextFrame.TextRange.InsertAfter "" & i
        End With
        
        s2.MoveTo ActivePresentation.Slides.Count
        
        Dim i2 As Integer, h As Shape
        Dim Del As New Collection
        For i2 = s2.Shapes.Count To 1 Step -1
            Set h = s2.Shapes(i2)
            If Not IsVisible(s2, h, k) Then Del.Add h
        Next
        Dim j As Integer
        For j = s.TimeLine.MainSequence.Count To 1 Step -1
            s2.TimeLine.MainSequence.Item(1).Delete
        Next
        For j = Del.Count To 1 Step -1
            Del(j).Delete
            Del.Remove j
        Next
    Next
Next
End Sub

'is the shape on this slide visible at point this time step (1..n)
Function IsVisible(s As Slide, h As Shape, i As Integer) As Boolean

'first search for a start state
Dim e As Effect
IsVisible = True
For Each e In s.TimeLine.MainSequence
    If e.Shape Is h Then
        IsVisible = Not (e.Exit = msoFalse)
        Exit For
    End If
Next

'now run forward animating it
Dim n As Integer: n = 1
For Each e In s.TimeLine.MainSequence
    If e.Timing.TriggerType = msoAnimTriggerOnPageClick Then n = n + 1
    If n > i Then Exit For
    If e.Shape Is h Then IsVisible = (e.Exit = msoFalse)
Next
End Function

'How many animation steps are there
'1 for a slide with no additional elements
Function AnimationElements(s As Slide) As Integer
AnimationElements = 1
Dim e As Effect
For Each e In s.TimeLine.MainSequence
    If e.Timing.TriggerType = msoAnimTriggerOnPageClick Then
        AnimationElements = AnimationElements + 1
    End If
Next
End Function

Sub RemElements()
Dim i As Integer, n As Integer
Dim s As Slide
n = ActivePresentation.Slides.Count
For i = n To 1 Step -1
    Set s = ActivePresentation.Slides(i)
    If s.SlideShowTransition.Hidden = msoTrue Then
        s.SlideShowTransition.Hidden = msoFalse
    ElseIf Left$(s.Name, 13) = "AutoGenerated" Then
        s.Delete
    End If
Next
End Sub

　这里出现的也页码会自动出现在左上方，可以更改代码中的这一行的数字从而改变其页码的位置

 Set oshp = .AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 50)

改成如下：
 Set oshp = .AddTextbox(msoTextOrientationHorizontal, 698, 510, 100, 50)

这时候页码位置就会在右下角位置了！注意在改了之后，需要将原来自动产生的文件点击 RemElments ,运行之后重新点击AddElements,再运行；

　

代码一链接：http://neilmitchell.blogspot.com/2007

代码二 链接：https://gist.github.com/pcmoritz/4b0e

备份：https://github.com/MMehrez/Convert_PP

 

参见视频：