Question

我正在创建一个数据库，该数据库根据用户的当前日期自动更新所有信息。
但是有一个问题，如果用户的日期设置有误，就意味着整个系统都被攻陷了。我想到的唯一解决方案是获取用户的区域设置和用户的时区，并使用它来确定时间和日期是否错误，以便数据库不会更新。但到目前为止，我发现无法使用 microsoft access 获取用户的时区和区域设置。有人能帮助我吗？我没有找到在 Access 中获取用户设置的功能或方法。我最接近的是 Application.LanguageSettings 。我真的迷路了。

Answer 1

您可以从远程 API 检索 UTC 时间：

' 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

然后检查 Now() 的日期/时间是否在 +/- 12 小时之内。

这需要对 Microsoft XML, v6.0 的引用。

Answer 2

您可以从注册表中读取区域设置。

VBA中读取registry的方式有很多种，我更喜欢用WScript.Shell，也有人用WinAPI（比较复杂，不过WScript.Shell可以屏蔽）

CreateObject("WScript.Shell").RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\TimeZoneKeyName")

如需更详细的时区信息，您可以使用 WinAPI。

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


Public Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(64) As Byte
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(64) As Byte
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Const TIME_ZONE_ID_STANDARD = 1
Const TIME_ZONE_ID_DAYLIGHT = 2

Public Declare PtrSafe Function GetTimeZoneInformation Lib "Kernel32.dll" (ByRef lpTimezoneInformation As TIME_ZONE_INFORMATION) As Long

Public Function GetBiasInHours() As Long
    Dim tzi As TIME_ZONE_INFORMATION
    Dim IsDST As Long
    IsDST = GetTimeZoneInformation(tzi)
    Dim Bias As Long
    If IsDST = TIME_ZONE_ID_DAYLIGHT Then
        Bias = tzi.DaylightBias / 60
    Else
        Bias = tzi.Bias / 60
    End If
    GetBiasInHours = Bias
End Function

偏差可用于计算与 UTC 时间的时间。 the documentation on the type 中描述了如何进行这些计算。当然，您也可以使用 StandardName 和 DaylightName 来检查时区是否按预期设置。您可以使用以下代码将这些转换为字符串：

Dim StandardNameString As String
StandardNameString = tzi.StandardName
StandardNameString = Left(StandardNameString, InStr(StandardNameString & vbNullChar, vbNullChar) - 1)

有没有办法在 microsoft access vba 中验证用户的时间和日期是否正确？

2 个答案: