Question

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

我想从互联网上提取日期，将其与系统日期进行比较，然后使用较晚的时间。我很难让VBA一起从互联网上取消日期，我有一个检测连接的功能。我还有脚本的结尾，禁用了发送电子邮件＆＃39;宏，所以他们不能通过电子邮件发送报告（他们不能没有互联网）。我确实借用了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...

当没有检测到互联网时退出SendMail子的目的是使他们无法启动发送电子邮件的过程，然后将更改的日期保存为草稿以供日后使用。我想强制使用正确的日期，而且我没有锁定其中一些概念

Answer 1

您需要按步骤

执行此操作

从互联网上获取UTC时间
将UTC转换为当地时间，并考虑到DST
比较PC时钟
申请公差

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

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

从Internet获取日期并与工作簿上的系统时钟比较打开

2 个答案: