Article ID: 162121
Article Last Modified on 10/11/2006
Sub GraphAnimationRandomizor()
Const NumEffects As Byte = 58
Dim SlideObject As Slide
Dim ShapeObject As Shape
Dim HoldRandomValue As Byte
' Make an array to store all the different types
' of Entry Animation Effects
Dim EffectList(1 To NumEffects) As Long
Dim GraphCount As Long
' Initialize the graph counter
GraphCount = 0
' Set up the Effect list
SetUpEffectList EffectList()
' Outer loop goes through every slide in the Active presentation
For Each SlideObject In Application.ActivePresentation.Slides
' Inner loop goes through every shape in the presentation
For Each ShapeObject In SlideObject.Shapes
' Check if the shape is an OLE object
If ShapeObject.Type = msoEmbeddedOLEObject Then
' Check if the shape is a graph
If ShapeObject.OLEFormat.ProgID = "MSGraph.Chart.8" Then
With ShapeObject.AnimationSettings
' This property must be set to True for any of the
' other properties of the AnimationSettings object
' to take effect.
.Animate = msoTrue
' Get a Random number
Randomize
HoldRandomValue = Int((NumEffects * Rnd) + 1)
' Assigns a random animatation to the graph
.EntryEffect = EffectList(HoldRandomValue)
End With
' Increment the graph counter
GraphCount = GraphCount + 1
End If
End If
Next ShapeObject
Next SlideObject
' Check if any graphs were changed
If GraphCount = 0 Then
MsgBox "No Graphs are available. No changes were made " _
& "to the presentation.", vbInformation, "No Graphs"
Else
' Set up the message box
If GraphCount = 1 Then
MsgBox "One Graph was given a random custom animation.", _
vbInformation, "Random Custom Animation"
Else
MsgBox "Suscessfully applied a custom animation to all " _
& "Graphs.", vbInformation, GraphCount & " Graphs Animated"
End If
End If
End Sub
' Assigns effect constants to the List Array
Sub SetUpEffectList(ByRef List() As Long)
' Appear
List(1) = ppEffectAppear
' Fly Effects
List(2) = ppEffectFlyFromBottom
List(3) = ppEffectFlyFromBottomLeft
List(4) = ppEffectFlyFromBottomRight
List(5) = ppEffectFlyFromLeft
List(6) = ppEffectFlyFromRight
List(7) = ppEffectFlyFromTop
List(8) = ppEffectFlyFromTopLeft
List(9) = ppEffectFlyFromTopRight
' Blinds Effects
List(10) = ppEffectBlindsHorizontal
List(11) = ppEffectBlindsVertical
' Box Effects
List(12) = ppEffectBoxIn
List(13) = ppEffectBoxOut
' Checkerboard Effects
List(14) = ppEffectCheckerboardAcross
List(15) = ppEffectCheckerboardDown
' Crawl Effects
List(16) = ppEffectCrawlFromDown
List(17) = ppEffectCrawlFromLeft
List(18) = ppEffectCrawlFromRight
List(19) = ppEffectCrawlFromUp
' Dissolve
List(20) = ppEffectDissolve
' Flash Effect
List(21) = ppEffectFlashOnceFast
List(22) = ppEffectFlashOnceMedium
List(23) = ppEffectFlashOnceSlow
' Peek Effect
List(24) = ppEffectPeekFromDown
List(25) = ppEffectPeekFromLeft
List(26) = ppEffectPeekFromRight
List(27) = ppEffectPeekFromUp
' Random Effects
List(28) = ppEffectRandomBarsHorizontal
List(29) = ppEffectRandomBarsVertical
' Spiral
List(30) = ppEffectSpiral
' Split Effects
List(31) = ppEffectSplitHorizontalIn
List(32) = ppEffectSplitHorizontalOut
List(33) = ppEffectSplitVerticalIn
List(34) = ppEffectSplitVerticalOut
' Stretch Effects
List(35) = ppEffectStretchAcross
List(36) = ppEffectStretchDown
List(37) = ppEffectStretchLeft
List(38) = ppEffectStretchRight
List(39) = ppEffectStretchUp
' Strips Effects
List(40) = ppEffectStripsDownLeft
List(41) = ppEffectStripsDownRight
List(42) = ppEffectStripsLeftDown
List(43) = ppEffectStripsLeftUp
List(44) = ppEffectStripsRightDown
List(45) = ppEffectStripsRightUp
List(46) = ppEffectStripsUpLeft
List(47) = ppEffectStripsUpRight
' Swivel
List(48) = ppEffectSwivel
' Wipe Effects
List(49) = ppEffectWipeDown
List(50) = ppEffectWipeLeft
List(51) = ppEffectWipeRight
List(52) = ppEffectWipeUp
' Zoom Effects
List(53) = ppEffectZoomBottom
List(54) = ppEffectZoomCenter
List(55) = ppEffectZoomIn
List(56) = ppEffectZoomInSlightly
List(57) = ppEffectZoomOut
List(58) = ppEffectZoomOutSlightly
End Sub
176476 OFF: Office Assistant Not Answering Visual Basic Questions
163435 VBA: Programming Resources for Visual Basic for Applications
Additional query words: 97 8.00 kbmacro kbpptvba ppt8 vba vbe macppt mac_ppt ppt98 98 powerpt
Keywords: kbcode kbdtacode kbhowto kbmacro kbprogramming KB162121