current date and time object

R

Randy Starkey

Hi,

Is there a way to have a current date and time box somewhere on a sheet? I
know the =now() function does it in a cell, but it only refreshes on macro
runs etc. I'm looking for something real time in the sheet.

Any ideas?

Thanks!

--Randy Starkey
 
B

Bob Phillips

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)
 
R

Randy Starkey

Thanks much! I'll give it a whirl.

--Randy


Bob Phillips said:
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)
Click to expand...
 
R

Randy Starkey

Bob,

Error on compile... AddressOf wouldn't compile. In this section.
Cell after this error showed time, no date, and the time was frozen at the
time of the macro execution.

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

Ideas?

Thanks! --Randy
 
B

Bob Phillips

Randy,

Try splitting it over 2 modules.

Add this to the first

Option Explicit

Sub StartClock()
Range("clock").Value = Format(Now, "Long Time")
fncWindowsTimer 1000
End Sub

Sub StopClock()
fncStopWindowsTimer
End Sub

Public 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


and this to another

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



Public 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


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


Public 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


Public 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


--

HTH

RP
(remove nothere from the email address if mailing direct)
 
R

Randy Starkey

OK. Thanks! I'll try that.

--Randy

Bob Phillips said:
Randy,

Try splitting it over 2 modules.

Add this to the first

Option Explicit

Sub StartClock()
Range("clock").Value = Format(Now, "Long Time")
fncWindowsTimer 1000
End Sub

Sub StopClock()
fncStopWindowsTimer
End Sub

Public 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


and this to another

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



Public 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


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


Public 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


Public 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


--

HTH

RP
(remove nothere from the email address if mailing direct)
Click to expand...
 
R

Randy Starkey

Hi Bob,

Got a variable not defined compile error here...

Public 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)

last line was highlighted in gray, first line in yellow.

Thanks,

--Randy
 
B

Bob Phillips

Randy,

I'll fire up 97 and try it later.

--

HTH

RP
(remove nothere from the email address if mailing direct)
 
R

Randy Starkey

Bob,

OK. I'm actually running Excel 2003 though. I guess you mean this was
composed in 97? Anyway, thanks for all the help!

--Randy
 
B

Bob Phillips

No, it was supposed tom be compatible for both, but there is special code
for 97. If you have 2003 it should be fine. Shall I post an example workbook
to the web which you can download and see it working?

--

HTH

RP
(remove nothere from the email address if mailing direct)
 
R

Randy Starkey

Bob,

That would be perfect! I would think I can get it from there.

Thanks,

--Randy
 
R

Randy Starkey

Hi Bob,

Got it. Works fine. Doesn't show the date though - can I modify the code to
do that? I'll try moving it to my sheet here in a minute...

Thanks!

--Randy
 
B

Bob Phillips

Randy,

There are a few places where the code says

Format(Now, "Long Time")

Change Long Time to a date time format, such as

Format(Now, "dd mmm yyyy, hh:mmss")

or whatever suits.

--

HTH

RP
(remove nothere from the email address if mailing direct)
 
Top