MS Access VBA日期区间校验问题：跨年场景代码失效

业务规则 #

• 客户需每年在7/1/YYYY（YYYY为动态获取的对应年份）前完成表单签署
• 若客户在6月签署表单，次年7/1之后需重新签署

现有代码问题 #

当前使用的VBA代码在跨年场景下无法正确判断认证日期是否处于有效区间，代码如下：

Private Sub Form_Load()
   Dim Curtefapdate As Date
   Dim Pretefapdate As Date

   Pretefapdate = DateSerial(Year(Date) - 1, 7, 1)
   Curtefapdate = DateSerial(Year(Date), 7, 1)
   
   If Not IsDate(Me.TEFAP_Date) Or Me.TEFAP_Date <= Curtefapdate Then
       DoCmd.SetProperty "recertreqwarn", acPropertyVisible, "-1"
       Beep
       MsgBox "TEFAP is out of date: " & Me.TEFAP_Date & " compared to a recert date of: " & Curtefapdate & ", please update now....", vbOKOnly, "Update TEFAP, Current Certification Period of " & Pretefapdate & " - " & Curtefapdate
   End If
End Sub

问题分析 #

原代码的判断逻辑错误，没有根据当前日期所处的时间段动态调整有效区间：

• 当当前日期在当年7/1之后时，原代码仍用当年7/1作为判断阈值，导致6月签署的有效日期被误判为过期（实际应到次年7/1后才过期）
• 当当前日期在当年7/1之前时，原代码没有区分更早的过期日期（比如上一年7/1之前签署的表单）

修正后的代码 #

以下代码根据当前日期动态计算有效区间，解决跨年场景的判断问题：

Private Sub Form_Load()
    Dim currentDate As Date
    Dim currentJuly1 As Date
    Dim prevJuly1 As Date
    Dim nextJuly1 As Date
    Dim isExpired As Boolean
    
    currentDate = Date
    currentJuly1 = DateSerial(Year(currentDate), 7, 1)
    prevJuly1 = DateSerial(Year(currentDate) - 1, 7, 1)
    nextJuly1 = DateSerial(Year(currentDate) + 1, 7, 1)
    
    ' 先判断日期是否有效
    If Not IsDate(Me.TEFAP_Date) Then
        isExpired = True
    Else
        If currentDate < currentJuly1 Then
            ' 当前日期在当年7/1之前，有效区间是[上一年7/1, 当年7/1)
            isExpired = (Me.TEFAP_Date < prevJuly1)
        Else
            ' 当前日期在当年7/1及之后，有效区间是[当年7/1, 下一年7/1)
            isExpired = (Me.TEFAP_Date < currentJuly1)
        End If
    End If
    
    ' 处理过期逻辑
    If isExpired Then
        DoCmd.SetProperty "recertreqwarn", acPropertyVisible, "-1"
        Beep
        ' 动态生成提示信息中的有效区间
        Dim validPeriod As String
        If currentDate < currentJuly1 Then
            validPeriod = prevJuly1 & " - " & currentJuly1
        Else
            validPeriod = currentJuly1 & " - " & nextJuly1
        End If
        MsgBox "TEFAP已过期：签署日期 " & Me.TEFAP_Date & "，当前有效认证区间为 " & validPeriod & "，请立即更新。", vbOKOnly, "更新TEFAP认证"
    End If
End Sub

代码说明 #

• 根据当前日期判断所处阶段（当年7/1前或后），动态确定有效认证区间
• 明确区分无效日期（非日期格式）和过期日期
• 提示信息中的有效区间随当前日期动态调整，符合业务规则
• 覆盖了跨年场景下的判断逻辑，比如当年6月签署的表单，在次年7/1之后才会被判定为过期

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