'SetTime2.vbs - Adjusts system time if off by 1 second or more.
'© Bill James - wgjames@mvps.org - rev 28 Apr 2000
'Credit to Michael Harris for original concept.
'
Option Explicit
Dim ws, strTitle
Set ws = CreateObject("WScript.Shell")
strTitle = "SetTime.vbs © Bill James"
'
'Check system compatibility.
Dim http
Call ChkCompat
'
'Read time zone offset hex value from Registry.
Dim TimeOffset, HexVal
TimeOffset = ws.RegRead("HKLM\SYSTEM\CurrentControlSet\" & _
             "Control\TimeZoneInformation\ActiveTimeBias")
'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
'
'Get time from server. Recheck up to 5 times if lagged.
Dim n, timechk, localdate, lag, gmttime
For n = 0 to 4
  'Fetch time page from US Naval Observatory web page.
  'We don't actually need or use the page contents.
  http.open "GET","http://tycho.usno.navy.mil" & _
            "/cgi-bin/timer.pl"& now(),false
  'Check response time to avoid invalid errors.
  timechk = Now
  http.send
  localdate = Now
  lag = DateDiff("s", timechk, localdate)
  '
  'Key concept for script is reading header date.
  gmttime = http.getResponseHeader("Date")
  '
  'Trim results to valid date format.
  gmttime = right(gmttime, len(gmttime) - 5)
  gmttime = left(gmttime, len(gmttime) - 3)
  '
  'If less than 2 seconds lag we can use the results.
  If lag < 2 Then Exit For
Next
'
'If still too much lag after 5 attemps, quit.
If n = 4 then
  ws.Popup "Unable to establish a reliable connection " & _
           "with time server.  This could be due to the " & _
           "time server being too busy, your connection " & _
           "already in use, or a poor connection." & vbcrlf & _
           vbcrlf & "Please try again later.", 5, strTitle
  Cleanup
End If
'
'Time and date error calculations.
Dim remotedate, diff, newnow, newdate, newtime, ddiff, sdiff
'Add local time zone offset to GMT returned from USNO server.
remotedate = DateAdd("h", timeoffset, gmttime)
'Calculate seconds difference betweed 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 = TimeValue(newnow)
'Convert time to 24 hr format required for OS compatibility.
newtime = Right(0 & Hour(newtime), 2) & ":" & _
          Right(0 & Minute(newtime), 2) & ":" & _
          Right(0 & Second(newtime), 2)
'Calculate time difference.
sdiff = DateDiff("s", time, newtime)
'
'If off by 1 or more seconds, adjust local time
Dim tmsg
If sdiff < 2 and sdiff > -2 Then
  tmsg = "System is accurate to within " & _
    "1 second.  System time not changed."
Else
  'Run DOS Time command in hidden window.
  ws.Run "%comspec% /c time " & newtime, 0
  tmsg = "System time off by " & sdiff & _
         " seconds.  System time changed to " & _
         CDate(newtime)
End If
'
'If date off, change it.
Dim dmsg
If ddiff <> 0 Then
  ws.Run "%comspec% /c date " & newdate, 0
  dmsg = "Date off by " & ddiff & _
         " days.  System date changed to " & _
         newdate & vbcrlf & vbcrlf
End If

'Show the changes
'ws.Popup dmsg & tmsg, 5, strTitle
'
Call Cleanup
'
Sub ChkCompat
  On Error Resume Next
  Set http = CreateObject("microsoft.xmlhttp")
  If Err.Number <> 0 Then
    ws.Popup "Process Aborted!" & vbcrlf & vbcrlf & _
             "Minimum system requirements to run this " & _
             "script are Windows 95 or Windows NT 4.0 " & _
             "with Internet Explorer 5.", , strTitle
    Cleanup
  End If
End Sub
'
Sub Cleanup
  Set ws = Nothing
  Set http = Nothing
  WScript.Quit
End Sub