A VB code for creating count down timer / stopwatch...

[sanskar_d]

Hi!

I have nothing to with programming. but in Excel I have used VB Editor for pasting codes to like number to words etc...

I think that it is possible to make a count down timer or a stop watch.

If yes, can anyone give me the code and method to do so?


regards,


Sam

[Bob Phillips]

Here is some code

set three cesll with the names countdown, start, and current. Set you
countdown time in countdown as time (00:00:30), and the n run StartClock.
Note I am using two code modules here.

Put this code in one code module

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


and this in another

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(CurrentVB*Project) = 0 Then
'...get the function ID of the callback function, based on its
'unicode-converted name, to ensure that it exists
aResult = GetFuncID(hProject:=CurrentVBP*roject, _
strFunctionName:=UnicodeFuncti*onName, _
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:=CurrentVBPro*ject, _
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

"sanskar_d" <[email protected]> wrote
in message news:[email protected]...
>
> Hi!
>
> I have nothing to with programming. but in Excel I have used VB Editor
> for pasting codes to like number to words etc...
>
> I think that it is possible to make a count down timer or a stop watch.
>
>
> If yes, can anyone give me the code and method to do so?
>
>
> regards,
>
>
> Sam
>
>
> --
> sanskar_d
> ------------------------------------------------------------------------
> sanskar_d's Profile:
http://www.excelforum.com/member.php...o&userid=24217
> View this thread: http://www.excelforum.com/showthread...hreadid=380012
>

[keepITcool]

bob,

for vba6 that could be..
(skips the issue of AddressOf, but avoids the hwnd
by using a null parameter and the ID returned from settimer)

Dim lngTimer As Long

Public Sub startclock()
the uElapse is set in Milliseconds!
lngTimer = SetTimer(0&, 0&, 1000&, AddressOf DoTimer)
End Sub

Public Sub stopclock()
KillTimer 0&, lngTimer
End Sub

Public Sub DoTimer()
Sheet1.Cells(1, 1) = Time
End Sub


hth, Jurgen


--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


Bob Phillips wrote :

> Here is some code
>
> set three cesll with the names countdown, start, and current. Set you
> countdown time in countdown as time (00:00:30), and the n run
> StartClock. Note I am using two code modules here.
>
> Put this code in one code module
>
> 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
>
>
> and this in another
>
> 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(CurrentVB*Project) = 0 Then
> '...get the function ID of the callback function, based on its
> 'unicode-converted name, to ensure that it exists
> aResult = GetFuncID(hProject:=CurrentVBP*roject, _
> strFunctionName:=UnicodeFuncti*onName, _
> 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:=CurrentVBPro*ject, _
> 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