accounting for changes to system date

[danwand]

Hi all,

Was wondering whether anyone has any ideas on how to check that the current system date (date and time properties of windows XP) is correct and has not been inadvertently changed.

My worry is that if someone changes the system date, the functions i have written that use date() or now() to check or write values to a table will produce incorrect data.
As an example, when a user logs into the database i have a function that checks previously held details for staff commencement date, holiday entitlement and holiday incremented
In essence this function is used for adding 1 extra day to an employees current holiday entitlement if they have been working for the company for more than 5 years.
So the function reads a staffs commencement date(for only those records that have a value of 'no' for holiday incremented), adds 5 years to it and checks if this new date is less than or equal to date(), If true then i update the values of holiday entitlement to holiday entitlement + 1 and change holiday incremented to 'yes'.
But if this function is performed after the sytem date is inadvertently changed then the results of this function will be incorrect.

I guess that this problem holds for all instances where date() and now() functions are used to write values to tables.
Am i being over-cautious in this thinking, or is there a simple function that exists to ensure that the system date is correct.

Any thoughts would be appreciated.
Dan.

 

[KarMac21]

Here's a function I use to sync the local pc's date/time with that of the server they are being authenticated to:

Public Function SyncTime()
    Call Shell(Environ$("COMSPEC") & " /c  NET TIME " & GetTimeServer & " /SET /Y ", vbHide)
End Function

Private Function GetTimeServer() As String
    GetTimeServer = Environ$("LOGONSERVER")
End Function

Hope this Helps!!

Shane

 

[TheAceMan1]

How are ya danwand . . .

You'll need internet access to an [blue]time sync site[/blue], or [blue]software[/blue] you can run [blue]that does the same[/blue]. If you sync up this way, no need to check, as time will be set proper. Just be aware of delays due to traffic or site downtime. In your case i would restrict access to forms unless sync can be achieved.

Example software:
1st Atomic Time

See Ya! . . . . . .

 

[danwand]

Thanks for the reply guys.

I though i'd found an ideal solution...
I downloaded an vbscript file that connects to a time sync site and checks that the current system date is correct or displays a error message box if no internet connection is found.
Although i've had very little experience with vbscript i managed to create a function that runs the vbscipt:

Public Function runTimeCheck()
Dim sh As Object

Set sh = CreateObject("WScript.Shell")
sh.Run ("D:\Documents\DATABASES\Back-Front\SetTime.vbs")
End Function


I then created an autoexec macro that calls this function each time the database is opened.

So all this works well, but what i wanted to do was adapt the vbscript file so that if an error occured (i.e. no internet connect available) the error message explain to the user that the time could not be checked and the database will now be closed. I hoped i could then code a routine into the vbscript that would close the open database.

However after searching all day yesterday i couldn't find out how to do this. I can only find info on opening and closing a CONNECTION to an access database.

So i'm a little stuck at the moment, i guess i might have to give up on this idea and find a more appropriate way of doing things.

So again thanks for your suggestions, if you know anything about vbscript and could give me more insight i would be appreciated.

Thanks
Dan

 

[PHV]

What are you doing in VBS you can't do in VBA ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[danwand]

Hi PHV,

This is the vbscript file, i have no idea how to translate to VBA, if you could give me a start it would be great:

'SetTime2.vbs - Adjusts system time if off by 1 second or more.
'© Bill James - wgjames@mvps.org - September 02, 2000
'Credit to Michael Harris for original concept.
'Revised 9 Apr 2002
' Added error trap for time server being unavailable
' Added backup time server (NIST)

Option Explicit
Dim ws, strTitle
Set ws = CreateObject("WScript.Shell")
strTitle = "TimeKeeper"

'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 a NT system.
HexVal = Hex(TimeOffset)
End If

'Convert to minutes of time zone offset.
TimeOffset = - CLng("&H" & HexVal)

'Get time from server. Recheck up to 5 times if lagged.
Dim n, timechk, localdate, lag, gmttime
Dim timeserv

'Check primary server, US Naval Observatory
timeserv = "

http://tycho.usno.navy.mil/cgi-bin/timer.pl"&

now()
http.open "GET",timeserv,false
On Error Resume Next
http.send
If Err Then
'Use backup server, National Institute of Standards and Technology (NIST)
timeserv = "

http://www.nist.gov/"

err.Clear
End If
On Error GoTo 0

For n = 0 to 4
http.open "GET",timeserv,false
'Check response time to avoid invalid errors.
timechk = Now
On Error Resume Next
http.send
If Err Then
If Err = -2146697211 Then
MsgBox "Both Time Servers unavailable!"
Else
MsgBox "Unknown Error occurred, " & Err
End If
Wscript.Quit
End If
On Error GoTo 0
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("n", 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 = FormatDateTime(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 " & FormatDateTime(newdate,1) & vbcrlf & vbcrlf
End If

'Show the changes
ws.Popup "Time syncronizion using " & timeserv & vbcrlf & _
vbcrlf & dmsg & tmsg, 5, strTitle, 4096

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

Obviously i don't need all of the functionality of this script, i.e. All i need a vba function to do is get the time from the internet server, if system time is out of sync with internet time then change system time appropriately (without message detailing difference in the two times). If the times are in sync do nothing. If error message generated because there is no current internet connection then close the database with a message.

So the two main aspects that i have no idea how to implement using vba are connecting and retrieving the internet time from the server and getting the current system time.

Thanks for your time!

Dan