Re: current date and time object

Tech-Archive recommends: Fix windows errors by optimizing your registry

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)


"Randy Starkey" <randy.starkeyNOSPAM@xxxxxxxxxxxxxxxxxxxxxxx> wrote in
message news:11mj8f03tt3nfa9@xxxxxxxxxxxxxxxxxxxxx
> 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
>
>
>
>
> "Bob Phillips" <bob.phillips@xxxxxxxxxxxxxxxxxxxx> wrote in message
> news:ew94Vw43FHA.1396@xxxxxxxxxxxxxxxxxxxxxxx
> > 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)
> >
> >
> > "Randy Starkey" <randy.starkeyNOSPAM@xxxxxxxxxxxxxxxxxxxxxxx> wrote in
> > message news:11mglldj2n714ea@xxxxxxxxxxxxxxxxxxxxx
> >> Hi,
> >>
> >> Is there a way to have a current date and time box somewhere on a
***?
> >> 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 ***.
> >>
> >> Any ideas?
> >>
> >> Thanks!
> >>
> >> --Randy Starkey
> >>
> >>
> >
> >
>
>


.

Quantcast