求助：如何用VBA验证系统日期有效性以限制代码过期运行

确实，单纯靠本地系统日期做过期限制太容易被绕过了——用户只要改下系统时间就能轻松破解。我给你几个实用的方案，能有效提高破解门槛，你可以根据自己的需求选：

通过获取网络上的标准时间来做校验，用户没法修改网络时间，这个方法的可靠性最高。下面是调用网页响应头日期的VBA代码：

Private Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
    ByVal sAgent As String, _
    ByVal lAccessType As Long, _
    ByVal sProxyName As String, _
    ByVal sProxyBypass As String, _
    ByVal lFlags As Long) As LongPtr

Private Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" ( _
    ByVal hInet As LongPtr) As Boolean

Private Declare PtrSafe Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" ( _
    ByVal hInet As LongPtr, _
    ByVal sUrl As String, _
    ByVal sHeaders As String, _
    ByVal lHeadersLength As Long, _
    ByVal lFlags As Long, _
    ByVal lContext As LongPtr) As LongPtr

Private Declare PtrSafe Function InternetReadFile Lib "wininet.dll" ( _
    ByVal hFile As LongPtr, _
    ByVal sBuffer As String, _
    ByVal lNumBytesToRead As Long, _
    lNumberOfBytesRead As Long) As Boolean

Private Function GetNetworkDate() As Date
    Dim hInet As LongPtr, hUrl As LongPtr
    Dim buffer As String * 1024
    Dim bytesRead As Long
    Dim htmlContent As String
    Dim dateStr As String
    
    ' 初始化网络连接
    hInet = InternetOpen("VBA Time Check", 1, vbNullString, vbNullString, 0)
    If hInet = 0 Then Exit Function
    
    ' 访问返回标准日期的网站（这里用百度，你也可以换其他稳定的站点）
    hUrl = InternetOpenUrl(hInet, "http://www.baidu.com", vbNullString, 0, &H80000000, 0)
    If hUrl = 0 Then
        InternetCloseHandle hInet
        Exit Function
    End If
    
    ' 读取网页内容
    Do While InternetReadFile(hUrl, buffer, 1024, bytesRead)
        If bytesRead = 0 Then Exit Do
        htmlContent = htmlContent & Left(buffer, bytesRead)
    Loop
    
    ' 关闭网络连接
    InternetCloseHandle hUrl
    InternetCloseHandle hInet
    
    ' 从响应头提取日期字段（格式类似 "Wed, 17 May 2018 08:00:00 GMT"）
    dateStr = Mid(htmlContent, InStr(htmlContent, "Date: ") + 6, 29)
    If dateStr <> "" Then
        GetNetworkDate = CDate(Mid(dateStr, 6, 20)) ' 转换为本地日期格式
    End If
End Function

Private Sub Workbook_Open()
    Dim networkDate As Date
    networkDate = GetNetworkDate
    
    ' 优先用网络时间校验，无网时用本地时间+文件属性做兜底
    If Not IsEmpty(networkDate) Then
        If networkDate > DateSerial(2018, 5, 17) Then
            ThisWorkbook.Close SaveChanges:=False
        End If
    Else
        ' 无网场景：检查本地日期是否早于文件创建日期超过7天（防止用户改过去的时间）
        Dim fileCreateDate As Date
        fileCreateDate = ThisWorkbook.BuiltinDocumentProperties("Creation Date")
        If Date < fileCreateDate - 7 Or Date > DateSerial(2018, 5, 17) Then
            ThisWorkbook.Close SaveChanges:=False
        End If
    End If
End Sub

优缺点：

• 优点：几乎无法被普通用户绕过，可靠性高
• 缺点：依赖网络连接，无网时需要兜底逻辑

把过期日期加密后藏在文档的自定义属性里，同时结合文件的创建/修改时间做校验，防止用户篡改系统时间。

Private Sub Workbook_Open()
    ' 从自定义属性获取加密后的基准日期（这里用简单的日期偏移，你可以用更复杂的加密逻辑）
    Dim baseDate As Date
    On Error Resume Next
    baseDate = DateAdd("d", -100, ThisWorkbook.CustomDocumentProperties("ExpiryOffset").Value)
    On Error GoTo 0
    
    ' 兜底：如果自定义属性丢失，用默认过期日期
    If IsEmpty(baseDate) Then baseDate = DateSerial(2018, 5, 17)
    
    ' 获取文件的创建和修改时间
    Dim createDate As Date, modifyDate As Date
    createDate = ThisWorkbook.BuiltinDocumentProperties("Creation Date")
    modifyDate = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
    
    ' 校验逻辑：
    ' 1. 本地日期晚于过期日期
    ' 2. 本地日期早于文件创建日期超过7天（用户改了过去的时间）
    ' 3. 文件修改日期早于创建日期（异常篡改）
    If Date > baseDate Or Date < createDate - 7 Or modifyDate < createDate Then
        ThisWorkbook.Close SaveChanges:=False
    End If
End Sub

' 初始化自定义属性（只需要运行一次，之后可以删除或注释掉）
Private Sub InitExpiryDate()
    On Error Resume Next
    ThisWorkbook.CustomDocumentProperties.Add Name:="ExpiryOffset", LinkToContent:=False, _
        Type:=msoPropertyTypeDate, Value:=DateAdd("d", 100, DateSerial(2018, 5, 17))
    On Error GoTo 0
End Sub

优缺点：

• 优点：无需联网，适合离线场景
• 缺点：如果用户会修改文件属性或破解VBA密码，还是有被绕过的可能，适合阻止普通用户

读取系统安装时间这个用户很难修改的时间点，通过计算安装日期到当前日期的天数，和安装日期到过期日期的天数做对比，判断用户是否篡改了系统时间。

Private Function GetSystemInstallDate() As Date
    Dim objShell As Object
    Set objShell = CreateObject("WScript.Shell")
    Dim installDateStr As String
    
    ' 读取系统安装时间的注册表项（注意64位系统可能需要调整路径）
    installDateStr = objShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\InstallDate")
    If installDateStr <> "" Then
        ' 把Unix时间戳转换为本地日期
        GetSystemInstallDate = DateAdd("s", CLng(installDateStr), #1/1/1970#)
    End If
    Set objShell = Nothing
End Function

Private Sub Workbook_Open()
    Dim installDate As Date
    installDate = GetSystemInstallDate
    Dim expiryDate As Date
    expiryDate = DateSerial(2018, 5, 17)
    
    ' 校验逻辑：如果本地日期晚于过期日，且从安装日到当前日的天数超过安装日到过期日的天数
    ' 说明用户改了未来的时间
    If Date > expiryDate Then
        Dim daysSinceInstall As Long, daysToExpiry As Long
        daysSinceInstall = DateDiff("d", installDate, Date)
        daysToExpiry = DateDiff("d", installDate, expiryDate)
        If daysSinceInstall > daysToExpiry Then
            ThisWorkbook.Close SaveChanges:=False
        End If
    End If
End Sub

优缺点：

• 优点：无需联网，系统安装时间很难被篡改
• 缺点：注册表路径可能因系统版本/位数不同而变化，需要适配

注意：没有绝对完美的VBA保护方案，因为本地运行的代码总有被逆向破解的可能，但以上方案能大幅提高破解门槛，满足大部分场景的需求。

内容的提问来源于stack exchange，提问作者user3357429