Count up timer for PP?

Question

Can anyone help me in building a count up timer for PowerPoint 2010. IT needs to be setup so that the number will continue to count up on the slide it will be positioned. It will be used for a days without injury slide if that helps at al

Answer 1

Here is an example for you to try.  Build it, confirm that it works, and then try to apply it to your specific needs.

Steps:

1. Open a blank PowerPoint presentation with a single, blank slide
2. Do a "Save As" and save it as a ".pptm" (macro enabled) file
3. Insert a single TextBox.  Type in "00:00:00".  Format the font, font size, etc, as desired.
4. Rename the TextBox "TimerTextBox" by selecting it, clicking on the Home tab, selecting "Select/Selection Pane..." and then typing a new name in for "TextBox 1"
5. Insert a single, "Custom" action button: Insert/Shapes/Action Buttons/Custom
6. Size the Action Button to exactly cover the text box.  Make the Action Button at least partially transparent to show the Text Box below it.
7. Click on the Developer tab, and select "Visual Basic"
8. In the Visual Basic Editor, select "Insert/Module" to insert a new code module.  Add the code below to that module.
9. Run the slideshow
10. Click on the action button to start the macro.
11. The count up should begin

Will this work for you?  It can easily be adapted to other needs.

Eric

'===== BEGIN CODE =====

Option Explicit

Private Const TIMERLIMIT As Single = 30# ' Number of seconds to count before stopping

Private Const UPDATEDELTA As Single = 1# ' Update display every (pick a value) seconds

Sub UpdateTimerTextBox()

    Dim tStr As String

    Dim time1 As Single, time2 As Single, time3 As Single

    Dim updateTime As Single

'

    time1 = Timer()

    time2 = Timer()

    time3 = Timer()

'

    ActivePresentation.Slides(1).Shapes("TimerTextBox").TextFrame.TextRange.Characters = "00:00:00"

    DoEvents

'

    While (time3 - time1 < TIMERLIMIT And Application.SlideShowWindows.Count > 0)

        time3 = Timer()

        If (time3 - time2 > UPDATEDELTA) Then

            tStr = Format((time3 - time1) / (24# * 60 * 60), "hh:mm:ss")

            ActivePresentation.Slides(1).Shapes("TimerTextBox").TextFrame.TextRange.Characters = tStr

            DoEvents

            time2 = time3

        End If

    Wend

End Sub

'====== END CODE =====

Answer 2

OK, try the version below.  I allows you to set a date for the start of the counting period.  There is no more limit to the loop.

'===== BEGIN CODE =====

Option Explicit

Private Const TIMERLIMIT As Single = 300000000# ' Number of days to count before stopping

Sub UpdateTimerTextBox()

    Dim tStr As String

    Dim time2 As Date, time3 As Date

    Dim updateTime As Single

    Dim startDateTime As Date ' What day/time to start with

    Dim delTime As Single

'

    startDateTime = "January 27, 2012 7:30:00 AM"

    time2 = Now - startDateTime

    time3 = time2

    tStr = "Days:" & Format(Int(time3), "000") & Format(time3, """  Hours:""hh""  Minutes:""mm""  Seconds:""ss")

    ActivePresentation.Slides(1).Shapes("TimerTextBox").TextFrame.TextRange.Characters = tStr

'

    DoEvents

'

    While (Application.SlideShowWindows.Count > 0)

        time3 = Now - startDateTime

        If ((time3 <> time2)) Then

            tStr = "Days:" & Format(Int(time3), "000") & Format(time3, """  Hours:""hh""  Minutes:""mm""  Seconds:""ss")

            ActivePresentation.Slides(1).Shapes("TimerTextBox").TextFrame.TextRange.Characters = tStr

            time2 = time3

            DoEvents

        End If

    Wend

End Sub

'===== END CODE =====

Answer 3

Hi,

This is exactly what I was also looking for.  I followed the instructions carefully, however the counter stays at when I press the button. 

00:00:00

I'm using PP 2016 is there something different I need to do, also I used a "blank action biutton because I couldn't find a "custom" option ?

thank in advance.

-Greg

Answer 4

Ok I think I figured that out now just fine tuning. Will let you know if I have any other issues. Thanks

Answer 5

hi!

ich hab versucht dein code so zu ändern, dass es countup mit Zahlen erstellt 0.00 bis 15.00, aber es funktioniert nicht so richtig. kannst du bitte da korrigieren?

'===== BEGIN CODE =====

Option Explicit

Private Const Stromverbrauch As Single = 15# ' Number of seconds to count before stopping

Private Const UPDATEDELTA As Single = 1# ' Update display every (pick a value) seconds

Sub UpdateTimerTextBox()

    Dim tStr As String

    Dim time1 As Single, time2 As Single, time3 As Single

    Dim updateTime As Single

    Dim Strom As Single

'

    Strom = 0

    time1 = Timer()

    time2 = Timer()

    time3 = Timer()

'

    ActivePresentation.Slides(1).Shapes("countuptextbox").TextFrame.TextRange.Characters = "0.00"

    DoEvents

'

    While (Strom < Stromverbrauch And Application.SlideShowWindows.Count > 0)

        time3 = Timer()

        If (time3 - time2 > UPDATEDELTA) Then

            tStr = CStr(Strom)

            ActivePresentation.Slides(1).Shapes("countuptextbox").TextFrame.TextRange.Characters = tStr

            DoEvents

            Strom = Strom + 0.01

            time2 = time3

        End If

    Wend

End Sub

'====== END CODE =====