Posted By

wesalvaro on 08/05/10

Tagged

animation

Versions (?)

Last Edited at 08/05/10 06:39am

Statistics

Viewed 579 times

Favorited by 0 user(s)

Related snippets

PowerPoint Timer

/ Published in: VB.NET

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.

Highlighted TextExpand

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

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

Report this snippet Tweet

Comments

Subscribe to comments

Comment:

You need to login to post a comment.