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 - - 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\TimeZoneInf ormation\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
'

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




"Dave Peterson" wrote in message
...
I keep a shortcut to a .vbs file on my desktop. I stole it from Bill
James &
Michael Harris:

http://groups.google.com/groups?thre...%40tkmsftngp04

I can just double click on it whenever I'm connected to the internet. And
I
don't have to load a special workbook in xl to adjust the time.



Martin wrote:

I have a procedure that runs from 07:45 to 17:00. The procedure itself
appears to be slowing the system clock in that this computer now shows
system time as 14:39, whereas the computer next to it (and unconnected)
shows the correct time of 14:44.

I know I can reset the system clock by rebooting, is there any way that
VBA
can be used to reset the clock within another procedure? Or VB or
Windows
API calls or anything??

Thank you
Martin

--

Dave Peterson