Implementing a Timer on a Slide using VBA

Hi there,

I was able to get this piece of code from John Wilson to implement a timer on my slide using VBA:

Code:

---

Sub Time_Me()
      Dim oshp As Shape
      Dim oshpRng As ShapeRange
      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 = 5
      Iduration = 120 'in seconds
    For i = Iduration To 0 Step -Istep
          Set oshpRng = osld.Shapes.Paste
          With oshpRng
              .Left = oshp.Left
              .Top = oshp.Top
          End With
          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

---

PROBLEM

John says "Simply create ONE shape or textbox with text in the style you need (Any text will do but make it as long as the longest possible time), select it and run the macro below."

For some reason unfortunately, I do not seem to be able to get it to work.

Can someone help me point out what I am doing wrong?

So, what happens when you try?

What should happen is the macro duplicates the shape you added but with appropriate "Time Text" then add animation to show the shapes in the correct order when in show mode.

Hi John,

So i finally managed to get the code working and improvised for what I want it to do. Here's what I come up with finally.

Code:

---

Sub Tmr()
    Dim TMinus As Integer
    Dim xtime As Date
    With ActivePresentation.Slides(5)
        With .Shapes(1)
            ' Countdown in seconds
            TMinus = 30
            Do While (TMinus > -1)
                ' Suspend  program execution for 1 second (1000 milliseconds)
                Sleep 1000
                xtime = Now
                .TextFrame.TextRange.Text = Format(TimeValue(Format(Now, "hh:mm:ss")) _
                - TimeSerial(Hour(Now), Minute(Now), Second(Now) + TMinus), "hh:mm:ss")
                TMinus = TMinus - 1
                ' Very crucial else the display won't refresh itself
                DoEvents
            Loop
        End With
    End With
End Sub

---

This is now, as you will notice, a simpler version where a 30 second timer runs when the shape (enabled with the Tmr Macro) is clicked.

However, i now want the time to be displayed only in SECONDS (as opposed to hh:mm:ss and unfortunately due to my inexperience in VBA I am not aware of a function which can do that. I will greatly appreciate your help if you can advise.

The next step is to be able to stop this counter when I jump to another slide and then continue the timer counter from where I left it when I come back to the slide which contains the Timer Shape.

Any guidance will be greatly appreciated

Using API calls is not a good idea if you are not a competant programmer. I wouldn't go there. The sleep API will prevent anything else happening. You could use the SetTimer API but that is even more tricky to use properly.

Also you should credit the author (Shyam Pillai) when you post his code.

If you insist though you could try this:

Code:

---

#If VBA7 Then
    ' allows for 64 bit
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Public Declare  Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub Tmr()
    Dim TMinus As Integer
    ' Countdown in seconds
    TMinus = 10
    With ActivePresentation.Slides(1).Shapes(1)
        Do While (TMinus > -1)
            ' Suspend program execution for 1 second (1000 milliseconds)
            Sleep 1000
            TMinus = TMinus - 1
            .TextFrame.TextRange = CStr(TMinus + 1) & "Secs"
            ' Very crucial else the display won't refresh itself
            DoEvents
        Loop
    End With
End Sub

---

If you want a timer running across the opresentation I would search for a free windows desktop timer. Most of these will run in front of your presentation.

A genius...John Wilson...thanks!
And indeed I have also credited Shyam Pillai as a comment in my code.

Now the entire purpose of such a timer in my application is that When I run another macro (by clicking an action button) the timer should stop, run the other sub routine, and when that routine is done, the timer should continue.

Going by your statement that the Sleep API will prevent anything else from happening, is the above achievable? If so, I would sincerely appreciate your guidance.

Thanks again for your expert advice.

The sleep APi basically puts the PC to sleep. So ... It probably won't see the click on the button.

SetTimer is the way to do this but you really need to know what you are doing/ SetTimer calls a macro memory location every xxxx micro seconds. This will do what you need BUT if anything is wrong and the called macro is not at that locatiion or throws an error you will totally crash the PC. Shyam has sample code on the same page but be careful! If you are able to adapt it so KillTimer is always called on error try it ... Don't blame me (or Shyam) when it crashes though!

You should make sure the Timer is killed when the slide show ends

You could add this in the TimerProc

Code:

---

If SlideShowWindows.Count < 1 Then
    bTimerState = True
    Call TimerOnOff
    Exit Sub
End If

---

It IS not completely foolproof though

Hi John,

Thanks for the suggestion, however, Shyam Pillai's SetTimer code counts from 1 upward. I tried to modify to count from 30 downward by initializing the SecondCtr = 30. The code keeps crashing on me.

Is there something I am doing incorrectly?

Code:

---

Option Explicit

       

' API Declarations

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
' Public Variables
Public SecondCtr As Integer

Public TimerID As Long
Public bTimerState As Boolean
       

Sub TimerOnOff()       

    If bTimerState = False Then
        TimerID = SetTimer(0, 0, 1000, AddressOf TimerProc)
        If TimerID = 0 Then
            MsgBox "Unable to create the timer", vbCritical + vbOKOnly, "Error"
            Exit Sub
        End If
        bTimerState = True
    Else   
        TimerID = KillTimer(0, TimerID)
        If TimerID = 0 Then
            MsgBox "Unable to stop the timer", vbCritical + vbOKOnly, "Error"
        End If
        bTimerState = False
    End If
End Sub

                 

' The defined routine gets called every nnnn milliseconds.

       

Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    SecondCtr = 30
    SecondCtr = SecondCtr - 1
    ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange.Text = CStr(SecondCtr)
End Sub

---