Implementing a Timer on a Slide using VBA

[nsalyani]

Hi there,

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

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?

[John Wilson]

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.

[nsalyani]

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.

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

[John Wilson]

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:

#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.

[nsalyani]

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.

[John Wilson]

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

If SlideShowWindows.Count < 1 Then
bTimerState = True
Call TimerOnOff
Exit Sub
End If
It IS not completely foolproof though

[nsalyani]

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?


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