Thread: Date & Time
View Single Post
  #3   Report Post  
mully
 
Posts: n/a
Default

Hi Bob

Thanks again but this is to long for me tonight been at it since about
11-00am - fortunately the customer I'm doing this for is still in Cardiff
drowning his sorrows so Tuesday pm will be ok - will get going early
tomorrow. Have up dated the local clubs web site - just a small site but it
suits them another job I do Club Sec and if you get me going about pigeons
we'll still be at it a month from now. So enough is enough for today - speak
to you soon.

http://pigeonsglossop.mysite.wanadoo-members.co.uk/

Cheers again ------ Mully

"Bob Phillips" wrote:

Hi Mully,

Here is some code. There is code for the userform, and some for 2 code
modules

Add this code to the userform

Private Sub Userform_Initialize()
Set timer = TextBox1
Set dater = TextBox2
StartClock
End Sub



'-----------------------------Â*------------------------------Â*--------------
'In one code module add this code


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


Public timer, dater

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
On Error Resume Next
timer.Value = Format(Now, "Long Time")
dater.Value = Format(Date, "dd/mm/yyyy")
End Function


Sub StartClock()
timer.Value = Format(Time, "Long Time")
dater.Value = Format(Date, "dd/mm/yyyy")
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("XLMÂ*AIN", _
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("XLMÂ*AIN", _
Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf("cbkRoutinÂ*e"))
End If

fncWindowsTimer = CBool(WindowsTimer)

DoEvents

End Function


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


'-----------------------------Â*------------------------------Â*--------------
'In another code module add this code


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(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






--

HTH

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


"mully" wrote in message
...
Hi

Is there a code I can insert in VBA that will constantly update - the time
and date in two separate text boxes on a User Form. That I use now - I

know
how to insert the text boxes on the User Form in Excel. The dates would

have
to be in UK format.

Cheers

Mully