I found this code at VB-Helper.com which uses a macro to set the system time
by retrieving the correct Atomic time from the NIST site. When they click
the button to clock-in or -out, you can have this code retrieve the current
NIST time first.
Private Sub Command1_Click() 'Main button to set the system
' time
On Error GoTo ErrHandler
Label3.Caption = "System Time has Not been Set Yet"
SetIt = 1 'Used to only set time if the time from the
' time server is valid and reportedly accurate
If Winsock1.State <> sckClosing Then 'Sometimes the
' Winsock gets delayed in the closing state, so
' make sure it is closed before trying again
If Winsock1.State = sckClosed Then 'If closed, ok to
' open, else close it
Timer1.Interval = 5000 'Start 5 second count to
' 'time' server
Timer1.Enabled = True
Screen.MousePointer = vbHourglass
Winsock1.LocalPort = 0 'Must be set to 0
Winsock1.RemoteHost = Trim$(Text1.Text) 'Address
' of NIST server
Winsock1.RemotePort = 13 '13, 37 or 123 'Use 13!
Winsock1.Protocol = 0 '1-UDP '0-TCP 'USE TCP!
Winsock1.Connect 'This is what goes out and gets
' the time
Else
Winsock1.Close
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
End If
Else
Winsock1.Close
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
End If
Exit Sub
ErrHandler:
SetIt = 0
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
MsgBox "The Winsock Connection is Unavailable."
Winsock1.Close
End Sub
'The server returns data similar to the following:
'
' 52949 03-11-06 16:23:43 00 0 0 650.2 UTC(NIST) *
'The following code parses this data, uses it to initialize a SYSTIME
structure, and then uses
'the SetSystemTime API function to set the system's time.
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) _
'Fires when data is received from server
Dim datDate As Date 'formatted date
Dim strData As String 'time string from net time server
Dim JSys As SYSTEMTIME
Dim RetVal As Integer
Dim Ct As Integer
On Error GoTo ErrHandler
Winsock1.GetData strData, vbString 'get string from
' server
datDate = FormatDateTime(strData) 'go format the new
' string
If msAdj <> 0 Then 'if msadj = 0 then do not set an
' offset
datDate = DateAdd("s", -1, datDate) 'only if msadj
' <> 0, subtract 1 sec from new time so addition
' of msadj is positive
End If
Label1.Caption = "Before " & Now 'time before adjustment
If SetIt = 1 Then 'If all is ok, set system time
'Initialize SYSTIME with new data
JSys.wYear = Year(datDate)
JSys.wMonth = Month(datDate)
JSys.wDayOfWeek = 0 'DayOfWeek(datDate)'Not used
JSys.wHour = Hour(datDate)
JSys.wMinute = Minute(datDate)
JSys.wSecond = Second(datDate)
JSys.wDay = Day(datDate)
If msAdj = 0 Then
JSys.wMilliseconds = 0 'No millisec offset
Else
JSys.wMilliseconds = ((10000 - msAdj) / 10) 'must
' be positive
End If
'Set system time with new data
Do Until RetVal <> 0 Or Ct > 9 'Make up to 10
' attempts to set the time
RetVal = SetSystemTime(JSys)
Ct = Ct + 1
Loop
Label2.Caption = "After " & Now 'time after
' adjustment
If RetVal <> 0 Then
Label3.Caption = "System Time was Set " & _
"Successfully"
Else
Label3.Caption = "There was an Error in Setting " & _
"Time"
End If
'Display time string that was sent from server
Text2.Text = strData
End If
SetIt = 0
Winsock1.Close
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
Exit Sub
ErrHandler:
SetIt = 0
Winsock1.Close
Screen.MousePointer = vbNormal
Timer1.Interval = 0
Timer1.Enabled = False
End Sub
