从 Internet 获取日期并与 Workbook Open 上的系统时钟进行比较

Question

我有一个使用当前日期的电子表格，找到下一个星期日并将下一个星期日作为一周结束日期。这个日期在每个星期日的午夜自动滚动。一些用户正试图进行系统时钟回滚，以便为自己分配机会来伪造在我的表单中输入的某些数据位。

我想从互联网上提取日期，将其与系统日期进行比较，然后使用较晚者。我很难将 VBA 放在一起从互联网上提取日期，并且我有一个检测连接的功能。我还有禁用“发送电子邮件”宏的脚本的结尾，因此他们无法通过电子邮件发送报告（如果没有互联网，他们就无法做到这一点）。我确实从here 借用了一些代码来尝试实现这一点，但是我无法在不经历漫长过程的情况下理解最佳应用程序。

我如何最好地解决从互联网收集日期的问题，以便与潜在的系统时钟回滚进行比较？

---- Function IsInternetConnected()----

Sub CheckTimeDate()

Dim NewDate
Dim NewTime
Dim ws1 As Worksheet
Dim ws5 As Worksheet
Dim wkEnd As Range
Dim http

    Const NetTime As String = "https://www.time.gov/"

On Error Resume Next
Set http = CreateObject("Microsoft.XMLHTTP")

http.Open "GET", NetTime & Now(), False, "", ""
http.send

NewTime = http.getResponseHeader("Date")

Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws5 = ThisWorkbook.Sheets("Sheet5")
Set wkEnd = ws1.Range("J3")

If IsInternetConnected() = True Then
    NewDate = NetDate
    ws1.wkEnd = .Value.NewDate

    ElseIf IsInternetConnected() = False Then

    On Error GoTo SysClockRollback
        wkEnd = Value.Date
    ElseIf NewDate > Date Then wkEnd = NewDate.Value
    Else: wkEnd = .Value.Date
    End If

Set ws1 = Nothing
Set wkEnd = Nothing
Set NetTime = Nothing

SysClockRollback:
MsgBox "The system clock appears to be incorrect. If the system clock was rolled back. This form will now use the local internet time for all dates. "

End Sub

----Sub SendMail()----
If IsInternetConnected() = False Then
    MsgBox "There is no Internet connection detected." & vbNewLine & _
    vbNewline & _
    "Please connect to the internet before sending.", vbApplicationModal, vbOKOnly
    Exit Sub
Else:
...and it goes into the SendMail Sub from there...

在未检测到 Internet 时退出 SendMail 子程序的目的是使他们无法启动发送电子邮件的过程，然后将更改的日期保存为草稿以供以后使用。我想强制使用正确的日期，而且我不会拘泥于其中的一些概念

Answer 1

您需要分步执行此操作

1. 从互联网获取 UTC 时间
2. 将 UTC 转换为当地时间，同时考虑 DST
3. 比较 PC 时钟
4. 应用容差

UTC 时间函数 from cpearson.com

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(0 To 31) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(0 To 31) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Private Enum TIME_ZONE
    TIME_ZONE_ID_INVALID = 0
    TIME_ZONE_STANDARD = 1
    TIME_ZONE_DAYLIGHT = 2
End Enum
Private Type DYNAMIC_TIME_ZONE_INFORMATION
    Bias As Long
    StandardName As String
    StandardDate As Date
    StandardBias As Long
    DaylightName As String
    DaylightDate As Date
    DaylightBias As Long
    TimeZoneKeyName As String
    DynamicDaylightTimeDisabled As Long
End Type

Private Declare Function GetTimeZoneInformationForYear Lib "kernel32" ( _
    wYear As Integer, _
    lpDynamicTimeZoneInformation As DYNAMIC_TIME_ZONE_INFORMATION, _
    lpTimeZoneInformation As TIME_ZONE_INFORMATION _
) As Long

Private Declare Function GetTimeZoneInformation Lib "kernel32" _
        (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long

Private Declare Sub GetSystemTime Lib "kernel32" _
        (lpSystemTime As SYSTEMTIME)

Function LocalOffsetFromGMT(Optional AsHours As Boolean = False, _
  Optional AdjustForDST As Boolean = False) As Double
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' LocalOffsetFromGMT
    ' This returns the amount of time in minutes (if AsHours is omitted or
    ' false) or hours (if AsHours is True) that should be *added* to the
    ' local time to get GMT. If AdjustForDST is missing or false,
    ' the unmodified difference is returned. (e.g., Kansas City to London
    ' is 6 hours normally, 5 hours during DST. If AdjustForDST is False,
    ' the resultif 6 hours. If AdjustForDST is True, the result is 5 hours
    ' if DST is in effect.)
    ' Note that the return type of the function is a Double not a Long. This
    ' is to accomodate those few places in the world where the GMT offset
    ' is not an even hour, such as Newfoundland, Canada, where the offset is
    ' on a half-hour displacement.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim TBias As Long
    Dim TZI As TIME_ZONE_INFORMATION
    Dim DST As TIME_ZONE
    DST = GetTimeZoneInformation(TZI)

    If DST = TIME_ZONE_DAYLIGHT Then
        If AdjustForDST = True Then
            TBias = TZI.Bias + TZI.DaylightBias
        Else
            TBias = TZI.Bias
        End If
    Else
        TBias = TZI.Bias
    End If
    If AsHours = True Then
        TBias = TBias / 60
    End If

    LocalOffsetFromGMT = TBias
End Function

上网时间整理你的代码

Function GetUCTTimeDate() As Date
    Dim UTCDateTime As String
    Dim arrDT() As String
    Dim http As Object
    Dim UTCDate As String
    Dim UTCTime As String

    Const NetTime As String = "https://www.time.gov/"

    On Error Resume Next
    Set http = CreateObject("Microsoft.XMLHTTP")
    On Error GoTo 0

    http.Open "GET", NetTime & Now(), False, "", ""
    http.send

    UTCDateTime = http.getResponseHeader("Date")
    UTCDate = Mid(UTCDateTime, InStr(UTCDateTime, ",") + 2)
    UTCDate = Left(UTCDate, InStrRev(UTCDate, " ") - 1)
    UTCTime = Mid(UTCDate, InStrRev(UTCDate, " ") + 1)
    UTCDate = Left(UTCDate, InStrRev(UTCDate, " ") - 1)
    GetUCTTimeDate = DateValue(UTCDate) + TimeValue(UTCTime)
End Function

比较时间

Function ClockDiff() As Double ' In Minutes
    Dim InternetDT As Date
    Dim UTC As Date
    Dim off As Double

    UTC = GetUCTTimeDate
    off = LocalOffsetFromGMT(True, True)
    InternetDT = DateAdd("h", -off, UTC)
    ClockDiff = DateDiff("n", Now(), InternetDT)
End Function

把它们放在一起

Sub Demo()
    Dim PcClockDiff As Double
    Const TOLERANCE = 10 ' minutes

    PcClockDiff = Abs(ClockDiff)
    If PcClockDiff > TOLERANCE Then
        MsgBox "Clock has been changed..."
    Else
        MsgBox "Clock is OK"
    End If
End Sub

Answer 2

我只是在玩弄类似的想法，尽管每次打开工作簿时都会在一个非常隐藏的工作表上跟踪当前系统时间。 如果他们尝试将时钟回滚到上次打开文件之前的日期/时间，则文件将关闭。

Sub datee()

Dim lastrow As Long
With Sheets("sheet1")

lastrow = Application.WorksheetFunction.CountA(.Range("A:A"))

.Range("a" & lastrow).Offset(1, 0).Value = Now


If Application.WorksheetFunction.Max(.Range("A:A")) > Now Then
        MsgBox ("Date has been tampered with")
    Else
        MsgBox ("Date appears good")
    End If

End With

End Sub

在这种情况下，唯一的问题是有机会在打开文件之前篡改日期。