Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
A VB code for creating count down timer / stopwatch...
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
A VB code for creating count down timer / stopwatch...
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" wrote in message ... 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
A VB code for creating count down timer / stopwatch...
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
45 Day Count Down Timer | Excel Worksheet Functions | |||
count down timer | Excel Discussion (Misc queries) | |||
count day timer | Excel Discussion (Misc queries) | |||
Is there a way to have a timer or stopwatch function in Excel. | Excel Worksheet Functions | |||
template timer stopwatch | Excel Worksheet Functions |