Posted By

wesalvaro on 08/05/10


Tagged

powerpoint timer macro counter animation ppt pptm


Versions (?)

PowerPoint Timer


 / Published in: VB.NET
 

URL: http://www.pptalchemy.co.uk/Animated_Timer2.html

Select a shape with text of any kind inside. Run the macro. A timer is generated. Change the macro to switch counter resolution, length, up/down, etc. Modified original to make it work in PPT 2007.

  1. Sub duper2()
  2. Dim oshpRng As ShapeRange
  3. Dim oshp As Shape
  4. Dim osld As Slide
  5. Dim oeff As Effect
  6. Dim i As Integer
  7. Dim Iduration As Integer
  8. Dim Istep As Integer
  9. Dim dText As Date
  10. Dim texttoshow As String
  11. On Error GoTo errhandler
  12. If ActiveWindow.Selection.ShapeRange.Count > 1 Then
  13. MsgBox "Please just select ONE shape!"
  14. Exit Sub
  15. End If
  16. Set osld = ActiveWindow.Selection.SlideRange(1)
  17. Set oshp = ActiveWindow.Selection.ShapeRange(1)
  18. oshp.Copy
  19.  
  20. 'change to suit
  21. Istep = 1
  22. Iduration = 300 'in seconds
  23.  
  24. For i = Iduration To 0 Step -Istep
  25. Set oshpRng = osld.Shapes.Paste
  26. oshpRng(1).Left = osld.Shapes(1).Left
  27. oshpRng(1).Top = osld.Shapes(1).Top
  28. dText = CDate(i \ 3600 & ":" & ((i Mod 3600) \ 60) & ":" & (i Mod 60))
  29. If Iduration < 3600 Then
  30. texttoshow = Format(dText, "Nn:Ss")
  31. Else
  32. texttoshow = Format(dText, "Hh:Nn:Ss")
  33. End If
  34. oshpRng(1).TextFrame.TextRange = texttoshow
  35. Set oeff = osld.TimeLine.MainSequence _
  36. .AddEffect(oshpRng(1), msoAnimEffectFlashOnce, , msoAnimTriggerAfterPrevious)
  37. oeff.Timing.Duration = Istep
  38. Next i
  39. oshp.Delete
  40. Exit Sub
  41. errhandler:
  42. MsgBox "**ERROR** - Maybe nothing is selected?"
  43. End Sub

Report this snippet  

You need to login to post a comment.