Option Explicit
Private Const D0 As Date = #1/1/1970#
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
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(32) As Integer
         StandardDate As SYSTEMTIME
         StandardBias As Long
         DaylightName(32) As Integer
         DaylightDate As SYSTEMTIME
         DaylightBias As Long
End Type
Private Function lGetTimeBias() As Long    ' sys = loc + bias (в секундах)
         Dim TZI As TIME_ZONE_INFORMATION
         GetTimeZoneInformation TZI
         lGetTimeBias = TZI.Bias * 60
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

' число секунд с 01.01.1970 0:00:00 [время ЛОКАЛЬНОЕ]
Private Function dGetSeconds() As Double
         Const URL = "http://www.direct-time.ru/track.php?id=time_utc"
         Const bDEBUGMODE As Boolean = 0
         Const DT As Single = 3    ' секунд ожидания ответа

         On Error GoTo ErrHandler

         Dim objReq As Object    ' MSXML.XMLHTTPRequest
         Set objReq = CreateObject("MSXML2.XMLHTTP")

         With objReq
             .Open "GET", URL, True
             .setRequestHeader "If-Modified-Since", "1"
             .Send Null

             Dim tOff As Single: tOff = Timer + DT

             Do
                 If .readyState = 4 Then
                     If .Status = 200 Then Exit Do
                 End If
                 If Timer > tOff Then Err.Raise 999, , "время истекло"
                 DoEvents
             Loop

             ' мс ---> с
             dGetSeconds = Int(CDbl(.responseText) / 1000) - lGetTimeBias
         End With

ErrExit:
         Set objReq = Nothing
         Exit Function

ErrHandler:
         Debug.Print Err.Number; Err.Description
         dGetSeconds = 0
         If bDEBUGMODE Then
             Stop
             Resume
         Else
             Resume ErrExit
         End If
End Function

'==============================================================
Function dteGetNow() As Date
         Dim i As Integer, dSec As Double
         For i = 1 To 3
             dSec = dGetSeconds  ' 3 попытки подключения!
             If dSec > 0 Then
                 dteGetNow = DateAdd("s", dSec, D0)
                 Exit Function
             End If
         Next i
         dteGetNow = Now         ' не получилось, берем системное
End Function