Excel如何设置工作簿仅在每日首次打开时自动运行宏

我有一份用于监控分包商保险投保状态的Excel电子表格：当表格某列记录的保险到期日已过（即保险失效）时，记载续保日期的单元格会从绿色变为红色，相邻单元格的取值会从True变为False，该取值变更事件会触发内置代码，自动发送邮件提醒对应保险已过期。
当前配置的宏会在每次打开工作簿时自动运行，但该工作簿每日会被多次打开、关闭，且提醒邮件会抄送多名工作人员，为避免重复发送相同邮件打扰相关人员，需要实现仅在工作簿每日首次被打开时运行该宏的效果。

• 触发邮件发送的代码，存放于"Sheet 1"代码窗口：

Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    Set xRg = Intersect(Range("H3:H7,L3:L7,P3:P7, U3:U7"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value = False Then
        Call Mail_small_Text_Outlook
    End If
End Sub


Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Transport, " & vbNewLine & vbNewLine & _
              "Our records indicate a sub-contractor's cover has expired." & vbNewLine & _
              "- @Transport: Please check the Sub-Contractor Cover spreadsheet to determine the correct sub-contractor," & vbNewLine & _
              "- @Operations: please suspend the relevant sub-contractor until they supply a copy of their updated cover." & vbNewLine & _
              vbNewLine & vbNewLine & _
               "Best regards," & vbNewLine & _
               "Sub-Contractor Notification Service"
               
    On Error Resume Next
    With xOutMail
        .To = "Me@WorkAddress.co.uk"
        .CC = "Operations@WorkAddress.co.uk; OperationsManager@WOrkAddress.co.uk"
        .BCC = ""
        .Subject = "(Test) URGENT: A Sub-Contractor's Cover Has Expired"
        .Body = xMailBody
        .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

• 工作簿打开时触发宏运行的代码，存放于"This workbook"代码窗口：

Private Sub Workbook_open()
    Sheet1.Mail_small_Text_Outlook
End Sub

利用工作簿自定义文档属性存储上次发送提醒邮件的日期，不需要额外新建工作表存记录，不会破坏原有表格结构。打开工作簿时先校验上次发件日期，仅当日期与当前日期不一致时才执行发件逻辑，执行后自动更新存储的日期并保存工作簿，避免当日重复触发。
操作步骤：

1. 打开VBA编辑器，进入ThisWorkbook代码窗口，将原有Workbook_Open代码替换为以下内容：

Private Sub Workbook_Open()
    Dim lastRunDate As Variant
    Dim currentDate As Date
    currentDate = Date
    
    ' 读取已存储的上次发件日期
    On Error Resume Next
    lastRunDate = ThisWorkbook.CustomDocumentProperties("LastMailRunDate").Value
    On Error GoTo 0
    
    ' 首次运行无记录、或上次发件日期不是今日时，执行发件逻辑
    If IsEmpty(lastRunDate) Or CDate(lastRunDate) <> currentDate Then
        ' 先更新发件日期记录，避免程序异常导致重复触发
        On Error Resume Next
        If IsEmpty(lastRunDate) Then
            ' 自定义属性不存在时新建
            ThisWorkbook.CustomDocumentProperties.Add _
                Name:="LastMailRunDate", _
                LinkToContent:=False, _
                Type:=msoPropertyTypeDate, _
                Value:=currentDate
        Else
            ' 自定义属性已存在时更新值
            ThisWorkbook.CustomDocumentProperties("LastMailRunDate").Value = currentDate
        End If
        On Error GoTo 0
        
        ' 调用发邮件过程
        Sheet1.Mail_small_Text_Outlook
        
        ' 自动保存工作簿，持久化日期记录
        ThisWorkbook.Save
    End If
End Sub

说明：原有Sheet1中存储的单元格变更触发实时发件的逻辑不需要修改，手动更新表格导致保险状态变更时的实时提醒功能会正常保留，不受本次修改影响。

2. 保存代码后关闭VBA编辑器即可生效，当日首次打开工作簿时会正常发送提醒，后续当日内多次打开工作簿不会重复触发邮件。

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