Question

通过Access / VBA代码如果有人知道，我想从World Time Server捕获当前日期吗？

Answer 1

您的本地日期很容易找到，不需要网络服务器：

ThisDate = Date

您更有可能希望获得 UTC 时间。这需要一些代码：

Option Explicit

    Public 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

' Returns the current UTC time.
Private Declare PtrSafe Sub GetSystemTime Lib "kernel32" ( _
    ByRef lpSystemTime As SystemTime)


' Retrieves the current date from the local computer as UTC.
' Resolution is one day to mimic Date().
'
' 2016-06-09. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function UtcDate() As Date

    Dim SysTime     As SystemTime
    Dim Datetime    As Date
    
    ' Retrieve current UTC date.
    GetSystemTime SysTime
    
    Datetime = DateSerial(SysTime.wYear, SysTime.wMonth, SysTime.wDay)
    
    UtcDate = Datetime
    
End Function

要从远程源检索当前时间，可以使用如下函数：

' Retrieves the current UTC date and time from a remote source.
' Split seconds (milliseconds) are rounded to the second like VBA.Now does.
'
' Documentation:
'   http://worldtimeapi.org/
'
' 2018-09-11. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function DateUtcNow() As Date

    ' ServiceUrl for time service.
    Const ServiceUrl        As String = "http://worldtimeapi.org/api/timezone/etc/utc.txt"
    
    ' Fixed constants.
    Const Async             As Boolean = False
    Const StatusOk          As Integer = 200
    Const UtcSeparator      As String = "datetime: "
    Const IsoSeparator      As String = "T"
    
    ' Engine to communicate with the service.
    Dim XmlHttp             As XMLHTTP60
    
    Dim ResponseText        As String
    Dim UtcTimePart         As String
    Dim DateTimePart        As String
    Dim SplitSeconds        As Double
    Dim CurrentUtcTime      As Date
  
    On Error GoTo Err_DateUtcNow
    
    Set XmlHttp = New XMLHTTP60
    
    XmlHttp.Open "GET", ServiceUrl, Async

    XmlHttp.send

    ResponseText = XmlHttp.ResponseText
    If XmlHttp.status = StatusOk Then
        UtcTimePart = Split(ResponseText, UtcSeparator)(1)
        DateTimePart = Replace(Left(UtcTimePart, 19), IsoSeparator, " ")
        SplitSeconds = Val(Mid(UtcTimePart, 20, 7))
        CurrentUtcTime = DateAdd("s", SplitSeconds + 0.5, CDate(DateTimePart))
    End If
    
    DateUtcNow = CurrentUtcTime

Exit_DateUtcNow:
    Set XmlHttp = Nothing
    Exit Function

Err_DateUtcNow:
    MsgBox "Error" & Str(Err.Number) & ": " & Err.Description, vbCritical + vbOKOnly, "Web Service Error"
    Resume Exit_DateUtcNow

End Function

Answer 2

谢谢，我设法执行了。我添加了参考：Microsoft XML v6.0，并且能够使用下面的代码成功运行。非常感谢大家。

Public Function DateUtcNow() As Date

' ServiceUrl for time service.

Const ServiceUrl        As String = "http://worldclockapi.com/api/json/est/now"


' Engine to communicate with the service.
Dim XmlHttp             As XMLHTTP60
Dim ResponseText        As String
Dim txdata As Date

On Error GoTo Err_DateUtcNow

Set XmlHttp = New XMLHTTP60

XmlHttp.Open "GET", ServiceUrl, Async

XmlHttp.send

ResponseText = XmlHttp.ResponseText
If Not ResponseText Like "*currentdatetime*" Then txdata = ""
txdata = Mid(ResponseText, InStr(ResponseText, "currentdatetime") + 18, 10)
'MsgBox txdata
MsgBox Format(CDate(txdata), "dd/mm/yyyy")

Exit_DateUtcNow:
Set XmlHttp = Nothing
Exit Function

Err_DateUtcNow:
MsgBox "Error" & Str(Err.Number) & ": " & Err.Description, vbCritical + vbOKOnly, "Web Service Error"
Resume Exit_DateUtcNow
End Function

通过网站获取当前日期/时间

2 个答案: