Here is one example
Just paste the code in a general code module, name a cell 'clock' (menu
Insert>Name>Define) and then run the 'StartClock' macro.
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 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
Private WindowsTimer As Long
Sub StartClock()
Range("clock").Value = Format(Now, "Long Time")
fncWindowsTimer 1000
End Sub
Sub StopClock()
fncStopWindowsTimer
End Sub
Private Function fncWindowsTimer(TimeInterval As Long) As Boolean
Dim WindowsTimer As Long
WindowsTimer = 0
'if we are in 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_cbkCustomTimer)
Else 'use K.Getz & M.Kaplan function to get a pointer
WindowsTimer = SetTimer(hWnd:=FindWindow("XLMAIN", _
Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf("cbkCustomTimer"))
End If
fncWindowsTimer = CBool(WindowsTimer)
End Function
Private Function fncStopWindowsTimer()
KillTimer hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=WindowsTimer
End Function
Private Function cbkCustomTimer(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
Range("clock").Value = Format(Now, "Long Time")
End Function
Private Function AddrOf(CallbackFunctionName As String) As Long
'AddressOf operator replacement for Office97 VBA
'Authors: Ken Getz and Michael Kaplan
'
'declaration of local variables
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, in order 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
Private Function AddrOf_cbkCustomTimer() As Long
'Office97 VBE does not recognise the AddressOf operator;
'however, it does not raise a compile-error either...
AddrOf_cbkCustomTimer = vbaPass(AddressOf cbkCustomTimer)
End Function
Private Function vbaPass(AddressOfFunction As Long) As Long
vbaPass = AddressOfFunction
End Function
--
HTH
RP
(remove nothere from the email address if mailing direct)
