Bas module:
Code:
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