Create a user form called (frmTimer) with 2 labels side by side and a button on the bottom right. Make one label specialeffect 'Sunken' although this is a personal preference.
Call the labels "lblCurrent" and "lblNow" (minus the quotes)
Call the button "cmdQuit"
Now create 3 modules.
Module 1 - Called "modCallback"
Paste the following code:
Option Explicit
Option Private Module
' Win32 APIs
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
'Address of 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
Module 2 - Called "modClock"
Paste the following code:
Option Explicit
Option Private Module
' Public Properties
Public mClockView As String
Public mCountdown As Long
Public mTimer24 As Range
Public mTimerStart As Range
Public mTimerSecs As Range
Public mStartTime As Double
Public mStopTime As Double
Public mStopTotal As Double
'Private Properties
Private WindowsTimer As Long
Public Sub StartTimer()
mStartTime = Now
frmTimer.Show
'reset total stoppage time counter
mStopTotal = 0
fncWindowsTimer 1000, WindowsTimer '1 sec
End Sub
Public Sub StopTimer()
'save time clock stopped for later
mStopTime = Now
fncStopWindowsTimer
End Sub
Public Sub RestartTimer()
'add stoppage time to total stoppage time
mStopTotal = mStopTotal + Now - mStopTime
fncWindowsTimer 1000, WindowsTimer '1 sec
End Sub
Module 3 - Called "modShared"
Paste the following code:
Option Explicit
Option Private Module
' Application Constants
Public Const AppId As String = "xldTimer"
Public Const AppTitle As String = "xld Timer Add-In"
Public Const AppHead As String = "xld Timer"
Public Const AppMenu As String = "xld Ti&mer"
Public nTimeEnd As Double
' Win32 APIs
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
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
On Error Resume Next
UpdateForm
End Function
Public Function fncStopWindowsTimer()
KillTimer hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0 'WindowsTimer
End Function
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)
DoEvents
End Function
Public Function UpdateForm()
Dim nNow As Double
Dim nLeft As Double
nNow = Now
With frmTimer
.lblNow = Format(Date, "dd mmm yyyy") & " " & _
Format(nNow, "hh:mm:ss")
End With
End Function
Call ShowTimer to launch the form
Sub ShowTimer()
frmTimer.Show
End Sub
No comments:
Post a Comment