I'm trying to program a macro stopwatch for purpose of displaying it on
a TV scoreboard/"FoxBox", yet the information I've found online hasn't
proven precise. I'd like for this stopwatch to count down by tenths of
a second, in addition to count up as much as 100ths of a second (for
track races). Also, it needs to be able to restart where it left off
instead of reseting or continuing as though I hadn't stopped it.

I'm probably asking for too much, but every little bit helps.

Thought I'd update this:

I have the basics down (Starting and Stopping) and can now
pause/unpause without resetting. However, I'm still unsure as to how
to get my clock to tick down by tenths and jiffies (100ths).

atlashill wrote:
I'm trying to program a macro stopwatch for purpose of displaying it on
a TV scoreboard/"FoxBox", yet the information I've found online hasn't
proven precise. I'd like for this stopwatch to count down by tenths of
a second, in addition to count up as much as 100ths of a second (for
track races). Also, it needs to be able to restart where it left off
instead of reseting or continuing as though I hadn't stopped it.

I'm probably asking for too much, but every little bit helps.

Here is a previous post of mine. It is 1 sec precision, but can be adjusted
http://tinyurl.com/8fcc5

It does have a restart option, but it would be a sim-ple proce

Sub RestartClock()
fncWindowsTimer 1000, WindowsTimer '1 sec
End Sub

--
HTH

Bob Phillips

"atlashill" wrote in message
oups.com...
Thought I'd update this:

I have the basics down (Starting and Stopping) and can now
pause/unpause without resetting. However, I'm still unsure as to how
to get my clock to tick down by tenths and jiffies (100ths).

atlashill wrote:
I'm trying to program a macro stopwatch for purpose of displaying it on
a TV scoreboard/"FoxBox", yet the information I've found online hasn't
proven precise. I'd like for this stopwatch to count down by tenths of
a second, in addition to count up as much as 100ths of a second (for
track races). Also, it needs to be able to restart where it left off
instead of reseting or continuing as though I hadn't stopped it.

I'm probably asking for too much, but every little bit helps.

Are there any changes I need to make to adapt it to VB6.3 and/or Excel
for XP?

Right now I'm using Boolean operands to switch on/off my stopwatch.
Are there any changes I'll need to make to account for this, in
addition to this being in Excel for XP or VB 6.3?

How do you mean?

And it works for Excel XP.

--
HTH

Bob Phillips

"atlashill" wrote in message
oups.com...
Right now I'm using Boolean operands to switch on/off my stopwatch.
Are there any changes I'll need to make to account for this, in
addition to this being in Excel for XP or VB 6.3?

The code you supplied failed to stop counting when hitting zero, giving
me way too many prompt boxes to clear out.

Below are the stopwatch modules I've found online and augmented to fit.
As I said earlier, this below is capable of starting, stopping, and
restarting where it left off. I'd like to find a way to adapt your
code to fit this.

==========

First Module:

Declare Function timeGetTime Lib "winmm.dll" () As Long
Dim stopit As Boolean
Dim XCClock As Boolean
Dim StartTime

Sub RunTimer()
stopit = False
clock
End Sub

Sub clock()
If stopit = True Then Exit Sub
ActiveWorkbook.Worksheets(1).Range("C7").Value = _
Format(Now, "hh:mm:ss")
Application.OnTime (Now + TimeSerial(0, 0, 1)), "clock"
End Sub

Sub PauseTime()
stopit = True
End Sub

Sub StopClock()
XCClock = False
End Sub

Sub RestartClock()
XCClock = True
StartTime = TimeValue(Now())
ControlClock
End Sub

Sub ControlClock()
If XCClock = True Then
Range("C5").Value = Now - StartTime
Application.OnTime Now + TimeValue("00:00:01"), "ControlClock"
End If
End Sub

Second Module:

Dim AlarmTime As Date, AlarmTime2 As Date

Sub CountDown60()
ActiveSheet.Range("K1").Value = "60"
ActiveSheet.Range("K2").Value = "Counting"
Call TrapTime60
Call TrapTime
End Sub

Sub CountDown30()
ActiveSheet.Range("K1").Value = "30"
ActiveSheet.Range("K2").Value = "Counting"
Call TrapTime30
Call TrapTime
End Sub

Sub CountDownAgain()
ActiveSheet.Range("K1").Value = Range("K1").Value
ActiveSheet.Range("K2").Value = "Counting"
Call TrapTime
Call TrapTimeRestart
End Sub

Private Sub ShowTimeLeft()
ActiveSheet.Range("K1").Value = Second(AlarmTime - Now)
Call TrapTime
End Sub

Private Sub TrapTime60()
AlarmTime = CDate(Date) + TimeValue(Now()) + TimeValue("00:01:00")
Application.OnTime earliesttime:=AlarmTime, procedu="StopTimer"
End Sub

Private Sub TrapTime30()
AlarmTime = CDate(Date) + TimeValue(Now()) + TimeValue("00:00:30")
Application.OnTime earliesttime:=AlarmTime, procedu="StopTimer"
End Sub

Private Sub TrapTimeRestart()
AlarmTime = CDate(Date) + TimeValue(Now()) + Range("K3").Value
Application.OnTime earliesttime:=AlarmTime, procedu="StopTimer"
End Sub

Private Sub TrapTime()
AlarmTime2 = CDate(Date) + TimeValue(Now()) + TimeValue("00:00:01")
Application.OnTime earliesttime:=AlarmTime2, procedu="ShowTimeLeft"
End Sub

Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=AlarmTime2, procedu="showtimeleft",
schedule:=False
On Error GoTo 0
ActiveSheet.Range("K2").Value = "Done"
End Sub

My code uses an API timer not OnTime. They are different, you can't mix them
*well I am sure you could, but I can't see why you would bother - on or the
other).

Google has a habit of screwing up posts these days, so here are the two
modules re-posted

Option Explicit


Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long


Private Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long


Private Declare Function KillTimer Lib "user32" _
(ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long


Private WindowsTimer As Long


Public Function cbkRoutine(ByVal Window_hWnd As Long, _
ByVal WindowsMessage As Long, _
ByVal EventID As Long, _
ByVal SystemTime As Long) As Long
Dim CurrentTime As String
If Range("start") + Range("countdown") <= Range("current") Then
StopClock
MsgBox "All done"
Else
Range("current").Value = Format(Now, "Long Time")
End If
End Function


Sub StartClock()
Range("start").Value = Format(Now, "Long Time")
Range("current").Value = Format(Now, "Long Time")
fncWindowsTimer 1000, WindowsTimer '1 sec
End Sub


Sub StopClock()
fncStopWindowsTimer
End Sub


Sub RestartClock()
fncWindowsTimer 1000, WindowsTimer '1 sec
End Sub


Public Function fncWindowsTimer(TimeInterval As Long, WindowsTimer As Long)
As Boolean
WindowsTimer = 0
'if Excel2000 or above use the built-in AddressOf operator to
'get a pointer to the callback function
If Val(Application.Version) 8 Then
WindowsTimer = SetTimer(hWnd:=FindWindow("XLMAIN",
Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf_Callback_Routine)
Else 'use K.Getz & M.Kaplan function to get a pointer
WindowsTimer = SetTimer(hWnd:=FindWindow("XLMAIN",
Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf("cbkRoutine"))
End If


fncWindowsTimer = CBool(WindowsTimer)


End Function


Public Function fncStopWindowsTimer()
KillTimer hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0 'WindowsTimer
End Function





Option Explicit


Private Declare Function GetCurrentVbaProject Lib "vba332.dll" _
Alias "EbGetExecutingProj" _
(hProject As Long) As Long


Private Declare Function GetFuncID Lib "vba332.dll" _
Alias "TipGetFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionID As String) As Long


Private Declare Function GetAddr Lib "vba332.dll" _
Alias "TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionID As String, _
ByRef lpfnAddressOf As Long) As Long


'-----------------------------**-----------------------------*-*------------
--
Public Function AddrOf(CallbackFunctionName As String) As Long
'-----------------------------**-----------------------------*-*------------
--
'AddressOf operator emulator for Office97 VBA
'Authors: Ken Getz and Michael Kaplan
'-----------------------------**-----------------------------*-*------------
--
Dim aResult As Long
Dim CurrentVBProject As Long
Dim strFunctionID As String
Dim AddressOfFunction As Long
Dim UnicodeFunctionName As String


'convert the name of the function to Unicode system
UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode)


'if the current VBProjects exists...
If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then
'...get the function ID of the callback function, based on its
'unicode-converted name, to ensure that it exists
aResult = GetFuncID(hProject:=CurrentVBProject, _
strFunctionName:=UnicodeFunctionName, _
strFunctionID:=strFunctionID)
'if the function exists indeed ...
If aResult = 0 Then
'...get a pointer to the callback function based on
'the strFunctionID argument of the GetFuncID function
aResult = GetAddr(hProject:=CurrentVBProject, _
strFunctionID:=strFunctionID, _
lpfnAddressOf:=AddressOfFunction)
'if we've got the pointer pass it to the result of the function
If aResult = 0 Then
AddrOf = AddressOfFunction
End If
End If
End If


End Function


'-----------------------------**-----------------------------*-*------------
--
Public Function AddrOf_Callback_Routine() As Long
'-----------------------------**-----------------------------*-*------------
--
'Office97 VBE does not recognise the AddressOf operator;
'however, it does not raise a compile-error ...
'-----------------------------**-----------------------------*-*------------
--
AddrOf_Callback_Routine = vbaPass(AddressOf cbkRoutine)
End Function


'-----------------------------**-----------------------------*-*------------
--
Private Function vbaPass(AddressOfFunction As Long) As Long
'-----------------------------**-----------------------------*-*------------
--
vbaPass = AddressOfFunction
End Function




--
HTH

Bob Phillips

"atlashill" wrote in message
oups.com...
The code you supplied failed to stop counting when hitting zero, giving
me way too many prompt boxes to clear out.

Below are the stopwatch modules I've found online and augmented to fit.
As I said earlier, this below is capable of starting, stopping, and
restarting where it left off. I'd like to find a way to adapt your
code to fit this.

==========

First Module:

Declare Function timeGetTime Lib "winmm.dll" () As Long
Dim stopit As Boolean
Dim XCClock As Boolean
Dim StartTime

Sub RunTimer()
stopit = False
clock
End Sub

Sub clock()
If stopit = True Then Exit Sub
ActiveWorkbook.Worksheets(1).Range("C7").Value = _
Format(Now, "hh:mm:ss")
Application.OnTime (Now + TimeSerial(0, 0, 1)), "clock"
End Sub

Sub PauseTime()
stopit = True
End Sub

Sub StopClock()
XCClock = False
End Sub

Sub RestartClock()
XCClock = True
StartTime = TimeValue(Now())
ControlClock
End Sub

Sub ControlClock()
If XCClock = True Then
Range("C5").Value = Now - StartTime
Application.OnTime Now + TimeValue("00:00:01"), "ControlClock"
End If
End Sub

Second Module:

Dim AlarmTime As Date, AlarmTime2 As Date

Sub CountDown60()
ActiveSheet.Range("K1").Value = "60"
ActiveSheet.Range("K2").Value = "Counting"
Call TrapTime60
Call TrapTime
End Sub

Sub CountDown30()
ActiveSheet.Range("K1").Value = "30"
ActiveSheet.Range("K2").Value = "Counting"
Call TrapTime30
Call TrapTime
End Sub

Sub CountDownAgain()
ActiveSheet.Range("K1").Value = Range("K1").Value
ActiveSheet.Range("K2").Value = "Counting"
Call TrapTime
Call TrapTimeRestart
End Sub

Private Sub ShowTimeLeft()
ActiveSheet.Range("K1").Value = Second(AlarmTime - Now)
Call TrapTime
End Sub

Private Sub TrapTime60()
AlarmTime = CDate(Date) + TimeValue(Now()) + TimeValue("00:01:00")
Application.OnTime earliesttime:=AlarmTime, procedu="StopTimer"
End Sub

Private Sub TrapTime30()
AlarmTime = CDate(Date) + TimeValue(Now()) + TimeValue("00:00:30")
Application.OnTime earliesttime:=AlarmTime, procedu="StopTimer"
End Sub

Private Sub TrapTimeRestart()
AlarmTime = CDate(Date) + TimeValue(Now()) + Range("K3").Value
Application.OnTime earliesttime:=AlarmTime, procedu="StopTimer"
End Sub

Private Sub TrapTime()
AlarmTime2 = CDate(Date) + TimeValue(Now()) + TimeValue("00:00:01")
Application.OnTime earliesttime:=AlarmTime2, procedu="ShowTimeLeft"
End Sub

Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=AlarmTime2, procedu="showtimeleft",
schedule:=False
On Error GoTo 0
ActiveSheet.Range("K2").Value = "Done"
End Sub

For clarification, does the API timer essentially "free" the timer from
the computer clock?

For clarification, does the API timer essentially "free" the timer from
the computer clock?

Also, for some bizarre reason, Excel quits without mention seconds
after I stop the countdown.

Sorry if this keeps popping in and out; more stuff comes up and I'm not
quite up to having multiple replies sitting around.

1) For clarification, does the API timer essentially "free" the timer
from
the computer clock?
2) For some bizarre reason, Excel quits without mention seconds
after I stop the countdown.
3) Apparently I don't have vba332.dll. Would that instead be "vba632",
or would a different DLL file work?

It's taxing to wade through all the comments in the second module. I'm
nut sure which ones are pertinent to Excel XP. To what exactly is the
AddressOf suppose to callback?

The KillTimer function is not working.

The only difference is between Excel97 and later as 97 does not support
callbacks, so they are emulated.

The API timer stops the system getting bogged down, ad Ontime will do, and
it provides < 1 sec granularity.

It will fail if there is anything wrong in the code when callback triggers.
This is an unfortunate consequence of the beta Google groups, this failure.
If you like I can mail you a working workbook.

--
HTH

Bob Phillips

"atlashill" wrote in message
oups.com...
The KillTimer function is not working.

I'll put it in the post tomorrow.

--
HTH

Bob Phillips

"atlashill" wrote in message
ups.com...
Yes. Please do so.

Thank you for all your help.

How do I adjust precision? Am I suppose to change the number in the
command "fncWindowsTimer 1000"?