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