Get date/time from Internet

[Eduardo-]

Bas module:

Option Explicit

Private Const TIME_ZONE_ID_DAYLIGHT As Long = 2

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(63) As Byte
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(63) As Byte
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Private Declare Function GetTimeZoneInformation Lib "kernel32" (ByRef lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (lpnetconn As Long, ByVal dwReserved As Long) As Long

' Check for the result, if the "date" is 0 (zero), it means a problem, that can be that there is no internet or another error.
' Then the program can use the PC date or whatever.
Public Function GetInternetDateTime(Optional ReturnUTCDateTime As Boolean) As Date
    Dim oHTTP As Object
    Static sURLsTimeServers() As String
    Static sURLsTimeServersSet As Boolean
    Dim c As Long
    
    If Not IsInternetConnected Then Exit Function
    
    If Not sURLsTimeServersSet Then
        ReDim sURLsTimeServers(15)
        
        sURLsTimeServers(0) = "time.windows.com"
        sURLsTimeServers(1) = "time.google.com"
        sURLsTimeServers(2) = "pool.ntp.org"
        sURLsTimeServers(3) = "ntp.mailbox.co.uk"
        sURLsTimeServers(4) = "time1.google.com"
        sURLsTimeServers(5) = "time2.google.com"
        sURLsTimeServers(6) = "time3.google.com"
        sURLsTimeServers(7) = "time4.google.com"
        sURLsTimeServers(8) = "ntp0.ntp-servers.net"
        sURLsTimeServers(9) = "ntp1.ntp-servers.net"
        sURLsTimeServers(10) = "ntp2.ntp-servers.net"
        sURLsTimeServers(11) = "ntp3.ntp-servers.net"
        sURLsTimeServers(12) = "ntp.time.in.ua"
        sURLsTimeServers(13) = "ntp2.time.in.ua"
        sURLsTimeServers(14) = "ntp.ru"
        sURLsTimeServers(15) = "ntp.rsu.edu.ru"
        
        sURLsTimeServersSet = True
    End If
    
    Set oHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
    oHTTP.SetTimeouts 5000, 5000, 5000, 5000
    
    On Error Resume Next
    For c = 0 To UBound(sURLsTimeServers)
        Err.Clear
        oHTTP.Open "GET", "http://" & sURLsTimeServers(c) & "/", False
        oHTTP.Send
        If Err.Number = 0 Then Exit For
    Next
    
    ' the on Error Resume Next in the next lines is kept on purpose, if the server returned a malformed header we don't want the program to crash, but this function to return 0 (zero). The same as if there is no internet.
    If ReturnUTCDateTime Then
        GetInternetDateTime = ConvertHttpDateToVBDate(oHTTP.GetResponseHeader("Date"))
    Else
        GetInternetDateTime = UTCToLocalTime(ConvertHttpDateToVBDate(oHTTP.GetResponseHeader("Date")))
    End If
    On Error GoTo 0
    
End Function

Public Function IsInternetConnected() As Boolean
    Dim iConnectionState As Long
    Const cCTRUE = 1&
    
    IsInternetConnected = (InternetGetConnectedState(iConnectionState, 0) = cCTRUE)
End Function

Private Function UTCToLocalTime(ByVal DateTime As Date) As Date
    'Convert VB Date type value from UTC.
    Dim tzi As TIME_ZONE_INFORMATION
    Dim Result As Long
    Dim OffsetMinutes As Long
    
    'Return the time difference between local & UTC in minutes.
    Result = GetTimeZoneInformation(tzi)
    With tzi
        If Result = TIME_ZONE_ID_DAYLIGHT And .DaylightDate.wMonth <> 0 Then
            OffsetMinutes = .Bias + .DaylightBias
        Else
            OffsetMinutes = .Bias + .StandardBias
        End If
    End With
    
    'Apply total bias minutes: add to convert TO a UTC value
    'and subtract to convert FROM a UTC value.
    UTCToLocalTime = DateAdd("n", -OffsetMinutes, DateTime)
End Function

Private Function ConvertHttpDateToVBDate(nHttpDate As String) As Date
    Dim iDatePart As String
    
    If nHttpDate = "" Then Exit Function
    
    ' Remove the day of the week and time zone
    iDatePart = Mid(nHttpDate, InStr(nHttpDate, ",") + 2) ' Skip past the comma and space
    iDatePart = Left(iDatePart, InStr(iDatePart, " GMT") - 1) ' Remove " GMT"
    
    ' Convert to VB6 Date
    ConvertHttpDateToVBDate = CDate(iDatePart)
End Function

[BenJones]

Looks usfull I add it to my collection of VB tips maybe it come in handy for something, Thanks for shareing this code with us.

[yereverluvinuncleber]

Useful, now if I can find a way (that works) for setting the system time when it drifts (which all mine do regardless of time synchronisation settings) then I might add this code to a utility of mine that requires the system time to be accurately set.

[Eduardo-]

VB allows you to change the date and time, but you need to run the program with administrator rights:

    Dim InternetTime As Date
    
    InternetTime = GetInternetDateTime
    
    If InternetTime > 0 Then
        Debug.Print InternetTime, Now,
        Date = Int(InternetTime)
        Time = InternetTime
        Debug.Print Now
    End If

[yereverluvinuncleber]

Yes, I had similar, if not identical code in my program but it failed to work. I will have a think about running it with admin.

[xxdoc123]

 Case WM_TIMECHANGE
        
            RaiseEvent editTime(Date + Time)

        
        Case WM_POWERBROADCAST ' 
        
        
        If c_wParam = PBT_APMSUSPEND Then
            RaiseEvent PowerChangeEvent("Suspend")
        ElseIf c_wParam = PBT_APMRESUMESUSPEND Then
            RaiseEvent PowerChangeEvent("Resumed_User")
        ElseIf c_wParam = PBT_APMRESUMEAUTOMATIC Then
            RaiseEvent PowerChangeEvent("Resumed_Automatic")
        End If

I added a hook that can be modified for time. This allows the time to be automatically monitored and modified after start-up

The settings start with the computer booting, and the program does not automatically change the time