Advanced Search

Return to Snippet

Revision: 29932
at August 5, 2010 06:39 by wesalvaro
Initial Code 
Sub duper2()
    Dim oshpRng As ShapeRange
    Dim oshp As Shape
    Dim osld As Slide
    Dim oeff As Effect
    Dim i As Integer
    Dim Iduration As Integer
    Dim Istep As Integer
    Dim dText As Date
    Dim texttoshow As String
    On Error GoTo errhandler
    If ActiveWindow.Selection.ShapeRange.Count > 1 Then
        MsgBox "Please just select ONE shape!"
        Exit Sub
    End If
    Set osld = ActiveWindow.Selection.SlideRange(1)
    Set oshp = ActiveWindow.Selection.ShapeRange(1)
    oshp.Copy
    
    'change to suit
    Istep = 1
    Iduration = 300 'in seconds
    
    For i = Iduration To 0 Step -Istep
        Set oshpRng = osld.Shapes.Paste
        oshpRng(1).Left = osld.Shapes(1).Left
        oshpRng(1).Top = osld.Shapes(1).Top
        dText = CDate(i \ 3600 & ":" & ((i Mod 3600) \ 60) & ":" & (i Mod 60))
        If Iduration < 3600 Then
            texttoshow = Format(dText, "Nn:Ss")
        Else
            texttoshow = Format(dText, "Hh:Nn:Ss")
        End If
        oshpRng(1).TextFrame.TextRange = texttoshow
        Set oeff = osld.TimeLine.MainSequence _
        .AddEffect(oshpRng(1), msoAnimEffectFlashOnce, , msoAnimTriggerAfterPrevious)
        oeff.Timing.Duration = Istep
    Next i
    oshp.Delete
    Exit Sub
errhandler:
    MsgBox "**ERROR** - Maybe nothing is selected?"
End Sub
Initial URL 
http://www.pptalchemy.co.uk/Animated_Timer2.html
Initial Description 
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.
Initial Title 
PowerPoint Timer
Initial Tags 
animation
Initial Language 
VB.NET