Thank you Dave! I learned something new on the .vbs side. :>)
I did some further "research" also. Here is a quick and dirty modified
version of the code in an Excel vba module.
Here's what I have so far in case anyone else is interested. Not finalized,
or fully tested. I like to use speech, so most others may want to remove
that part.
There's room for all kinds of neat features and improvements.
I kept most of the variables as variants (similar to vbs), and will most
likely change them in the future.
Thanks again. :>)
Dana DeLouis
Sub SetClock()
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'SetTime2.vbs - Adjusts system time if off by 1 second or more.
'© Bill James - (e-mail address removed) - rev 28 Apr 2000
'Credit to Michael Harris for original concept.
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'Please Note: Original code adjusted here to work from within Excel VBA
'I like to use Speech for short messages, and inserted some ideas here.
'I kept both Speech and MsgBox/Popup for posting. Remove what you don't
want.
'Issues: If Clock is updated at exactly 23:59:57, and your clock is
' 10 seconds ahead (into the next day), the day warning may not be
' appropriate.
' A future version may want to redo a clock update close to midnight
' before returning any results.
' Making this a function may be nice.
' A return code could indicate the status.
' Examples:
' Too much time delay - bad connection.
' Close to Midnight
' Clock time is surprisingly off by a set amount.
' ** You may want to know if your clock was way off
' ** in case you just ran or printed some important documents or
reports.
' Dana DeLouis.
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
Dim ws
Dim http
Dim n As Long
Dim Msg As String
Dim Say As Speech
Dim TimeOffset, HexVal
Dim DateMsg, TimeMsg
Dim TimeChk, LocalDate, Lag, GMT_Time
Const strTitle As String = "SetTime.vbs © Bill James"
Const USNO As String = "
http://tycho.usno.navy.mil/cgi-bin/timer.pl"
Const msgOk As String = "System is accurate to within 1 second. System
time not changed."
Const strTimeOffset As String = _
"HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias"
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'// Speech stuff...
Const spkClockOk As String = "Clock checks ok!"
Const spkClockAdj As String = "Dana... I have adjusted your clock by #
seconds. You're welcome... as always."
Const spkDayWarning As String = "Warning. Your clock is off by more
than 1 day."
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
Set Say = Application.Speech
Set ws = CreateObject("WScript.Shell")
'Check system compatibility.
On Error Resume Next
Set http = CreateObject("microsoft.xmlhttp")
If Err.Number <> 0 Then
Msg = "Process Aborted!" & vbCrLf & vbCrLf
Msg = Msg & "Minimum system requirements to run this "
Msg = Msg & "script are Windows 95 or Windows NT 4.0 "
Msg = Msg & "with Internet Explorer 5."
MsgBox Msg, vbCritical, strTitle
GoTo Cleanup
End If
'Read time zone offset hex value from Registry.
TimeOffset = ws.RegRead(strTimeOffset)
' = = = = = Current Code = = = = = = = = = = = = = =
' Reg value format varies between Win9x and NT
If IsArray(TimeOffset) Then
'Win9x uses a reversed 4 element array of Hex values.
HexVal = Hex(TimeOffset(3)) & Hex(TimeOffset(2)) & _
Hex(TimeOffset(1)) & Hex(TimeOffset(0))
Else 'Must be NT system.
HexVal = Hex(TimeOffset)
End If
'Convert to hours of time zone offset.
TimeOffset = -CLng("&H" & HexVal) / 60
' = = = = = = = = = = = = = = = = = = = = = = = = = =
' = = = = = = = = = = = = = = = = = = = = = = = = = =
' Not sure, but the above code looks like it could be
' reduced on my system to this:
' TimeOffset = -CLng(TimeOffset / 60)
' = = = = = = = = = = = = = = = = = = = = = = = = = =
'Get time from server. Recheck up to 5 times if lagged.
For n = 1 To 5
'Fetch time page from US Naval Observatory web page.
http.Open "GET", USNO & Now(), False, "<proxy login>", "<password>"
'Check response time to avoid invalid errors.
TimeChk = Now
http.send
LocalDate = Now
Lag = DateDiff("s", TimeChk, LocalDate)
If Lag < 2 Then Exit For
Next
'
'If still too much lag after 5 attempts, quit.
If n > 5 Then
Msg = "Unable to establish a reliable connection"
Msg = Msg & "with time server. This could be due to the "
Msg = Msg & "time server being too busy, your connection "
Msg = Msg & "already in use, or a poor connection."
Msg = Msg & vbLf & vbLf
Msg = Msg & "Please try again later."
MsgBox Msg, vbInformation, vbOKOnly
GoTo Cleanup
End If
'
'Just read Header date.
GMT_Time = http.getResponseHeader("Date")
' = = = = = = = = = = = = = = = = = = = = = = = = = =
' My Note:
' Future idea may be to use
' GMT_Time = http.responseText
' and extract the time for your particular time zone.
' I would want to extract the Eastern Time Zone
' perhaps using a Regular Expression.
' Any thoughts on this?
' Thanks
' Dana DeLouis
' (e-mail address removed)
' <BR> May 28, 2004, 10:37:10 Eastern Daylight Time
' = = = = = = = = = = = = = = = = = = = = = = = = = =
GMT_Time = Mid$(GMT_Time, 6, Len(GMT_Time) - 9)
'Time and date error calculations.
Dim NewNow, NewDate, NewTime
Dim RemoteDate, diff, dDiff, tDiff
'Add local time zone offset to GMT returned from USNO server.
RemoteDate = DateAdd("h", TimeOffset, GMT_Time)
'Calculate seconds difference between remote and local.
diff = DateDiff("s", LocalDate, RemoteDate)
'Adjust for difference and lag to get actual time.
NewNow = DateAdd("s", diff + Lag, Now)
'Split out date and calculate any difference.
NewDate = DateValue(NewNow)
dDiff = DateDiff("d", Date, NewDate)
'Split out time.
NewTime = Format(TimeValue(NewNow), "hh:mm:ss")
tDiff = DateDiff("s", Time, NewTime)
'Adjust local time if off by 1 or more seconds.
If Abs(tDiff) < 2 Then
TimeMsg = msgOk
Say.Speak spkClockOk, True, , True
Else
'Run DOS Time command in hidden window.
ws.Run "%comspec% /c time " & NewTime, 0
TimeMsg = "System time adjusted by " & tDiff & " seconds."
Say.Speak Replace(spkClockAdj, "#", tDiff), True, , True
End If
'
'Adjust Date if necessary
If dDiff <> 0 Then
'Run DOS Date command in hidden window.
ws.Run "%comspec% /c date " & NewDate, 0
DateMsg = "Date adjusted by " & dDiff
Say.Speak spkDayWarning, True, , True
End If
'Show the changes
If Abs(tDiff) < 2 And dDiff = 0 Then
ws.Popup DateMsg & vbLf & TimeMsg, 3, strTitle
Else
ws.Popup DateMsg & vbLf & TimeMsg, 4, strTitle
End If
'
Cleanup:
Set ws = Nothing
Set http = Nothing
End Sub
Dana DeLouis
Windows & Office XP
(e-mail address removed)
