Attribute VB_Name = "Module1"
Option Explicit

'********************
'* Win32 Stubs . . .
'********************
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

'**************************
'* Win 32 Structures . . .
'**************************
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName As String * 64
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName As String * 64
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

'***********************
'* Win32 Constants . . .
'***********************
Private Const TIME_ZONE_ID_INVALID = &HFFFFFFFF
Private Const TIME_ZONE_ID_UNKNOWN = 0
Private Const TIME_ZONE_ID_STANDARD = 1
Private Const TIME_ZONE_ID_DAYLIGHT = 2

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000

'*******************************************************************
'* Title        Sub Main
'* Author       Mark Wilson
'* Date         17th March 2003
'*
'* Parameters   NONE
'*
'* Returns      Nothing
'*
'* Notes        This function corrects the system time
'*
'* History      17/03/2003      MW      Created
'*
'*******************************************************************
Private Sub Main()

    On Error GoTo ERR_Main
    
    Dim dUTC As Date
    Dim dLocalTime As Date
    Dim CurrentTime As Date

    CurrentTime = Now()
    
    '*******************************************************************
    '* Get UTC, and adjust according to system time zone settings . . .
    '*******************************************************************
    dUTC = GetUTC()
    dLocalTime = AdjustForTimeZone(dUTC, fAdjustForDaylightSavings:=True)
    
    '****************************
    '* Write Time To System . . .
    '****************************
    Time = dLocalTime
    
    '***********************
    '* Log the change . . .
    '***********************
    App.LogEvent "Changed Time From '" & Format$(CurrentTime, "hh:nn:ss") & "' To '" & dLocalTime & "'", vbLogEventTypeInformation
    
    Exit Sub
    
ERR_Main:

    Dim sErr As String
    sErr = "Unable To Update System Time Because '" & Err.Description & "'"
    App.LogEvent sErr, vbLogEventTypeError
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    
End Sub

'*******************************************************************************************
'* Title        Function GetUTC
'* Author       Mark Wilson
'* Date         17th March 2003
'*
'* Parameters   NONE
'*
'* Returns      Date    Coordinated Universal Time (UTC)
'*
'* Notes        Coordinated Universal Time is derived from Internation Atomic Time (TAI)
'*              in such a manner that it should never be more than 0.9 seconds inaccurate
'*
'*              This function derives UTC from the Atomic Clock as the US Naval Observatory
'*              It uses HTTP as it's protocol (as appose from NTP) to avoid firewall
'*              problems
'*
'* History      17/03/2003      MW      Created
'*
'*******************************************************************************************
Private Function GetUTC() As Date

    On Error GoTo ERR_GetUTC
    
    Dim sBuffer As String
    
    '***************************************************
    '* Get the HTML (in this case not well-formed) . . .
    '***************************************************
    sBuffer = OpenURL("http://tycho.usno.navy.mil/cgi-bin/timer.pl")
    
    '***********************************************
    '* Trim the crap, and retain the UTC entry . . .
    '***********************************************
    sBuffer = Right$(Left$(sBuffer, InStr(1, sBuffer, "Universal") - 4), 8)
    
    GetUTC = sBuffer
    
    Exit Function
    
ERR_GetUTC:

    Dim sErr As String
    sErr = "Unable To Get UTC Because '" & Err.Description & "'"
    App.LogEvent sErr, vbLogEventTypeError
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    
End Function

'*******************************************************************************************
'* Title        Function OpenURL
'* Author       Unknown
'* Date         Unknown
'*
'* Parameters   --> sURL    STRING      Universal Resource Locator
'*
'* Returns      STRING      Whatever the URL is
'*
'* Notes        Opens a URL and retrieves it's HTML (or otherwise)
'*              Got this function from the internet - if the author recognises this
'*              please let me know!
'*
'* History      17/03/2003      MW      Created
'*
'*******************************************************************************************
Private Function OpenURL(ByVal sUrl As String) As String

    On Error GoTo ERR_OpenURL

    Dim hOpen As Long
    Dim hOpenUrl As Long
    Dim bDoLoop As Boolean
    Dim bRet As Boolean
    Dim sReadBuffer As String * 2048
    Dim lNumberOfBytesRead As Long
    Dim sBuffer As String
    
    Const scUserAgent = "VB Project"
    
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0) 'force reload (don't use cache)

    bDoLoop = True
    
    Do While bDoLoop
    
        sReadBuffer = vbNullString
        bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
        sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
        
        If Not CBool(lNumberOfBytesRead) Then
            bDoLoop = False
        End If
        
    Loop

    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
    OpenURL = sBuffer

    Exit Function
    
ERR_OpenURL:

    InternetCloseHandle (hOpenUrl)
    InternetCloseHandle (hOpen)
    
    Dim sErr As String
    sErr = "Unable To Get URL Because '" & Err.Description & "'"
    App.LogEvent sErr, vbLogEventTypeError
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    
End Function

'*******************************************************************************************
'* Title        Function AdjustForTimeZone
'* Author       Mark Wilson (c) Batt Cables PLC
'* Date         17th March 2003
'*
'* Parameters   --> dTime                       DATE      The Time to adjust
'*              --> fAdjustForDaylightSavings   BOOLEAN   Include Daylight Saving adjustment
'*
'* Returns      DATE      The Adjusted dTime
'*
'* Notes        This function assumes that the system time zone is set correctly, and derives
'*              it's adjustment information from the Win32 subsystem
'*
'*              This function is based on UTC = local time + bias
'*
'* History      17/03/2003      MW      Created
'*
'*******************************************************************************************
Private Function AdjustForTimeZone(ByVal dTime As Date, ByVal fAdjustForDaylightSavings As Boolean) As Date

    On Error GoTo ERR_AdjustDaylightSavings
    
    Dim uTimeZone As TIME_ZONE_INFORMATION
    Dim lTZId As Long
    Dim lBias As Long
    
    lTZId = GetTimeZoneInformation(uTimeZone)
    
    Select Case lTZId
    
        Case TIME_ZONE_ID_DAYLIGHT
            lBias = uTimeZone.Bias
            If fAdjustForDaylightSavings Then
                lBias = lBias + uTimeZone.DaylightBias
            End If
            
        Case TIME_ZONE_ID_STANDARD
            lBias = uTimeZone.Bias
            
        Case TIME_ZONE_ID_INVALID
            Err.Raise vbObjectError + 512, , "Cannot Determine Time Zone Information"
            
        Case TIME_ZONE_ID_UNKNOWN
            App.LogEvent "Time Zone Is Unknown, Using Bias:" & uTimeZone.Bias, vbLogEventTypeWarning
            lBias = uTimeZone.Bias
            
            
    End Select
    
    AdjustForTimeZone = DateAdd("n", -lBias, dTime)
    
    Exit Function
    
ERR_AdjustDaylightSavings:

    Dim sErr As String
    sErr = "Cannot Adjust For Daylight Savings Because '" & Err.Description & "'"
    App.LogEvent sErr, vbLogEventTypeError
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    
End Function