1.office打开ppt
2.先点视图,再点宏
3.输入宏名,点创建
4.全选,粘贴以下代码
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
用VB语言写的,可能需要保存多次,可以点击仍然保存。
5.回到office,点:宏,选择第一个,点运行,第二个是还原回原来效果