Excel保存后发带附件邮件：共享文件夹数据同步延迟问题求助

问题描述 #

文件存储在共享网络文件夹中，保存后触发邮件发送，但因网络写入耗时较长，导致邮件附件仍是旧数据；本地存储时附件能正常包含新数据。需求为等待文件实际保存完成后再发送邮件，仅需完成保存关闭操作，无需其他额外步骤。

解决方案 #

核心思路是验证文件的实际写入状态，通过检查文件修改时间或尝试独占锁定文件，确认共享文件夹中的文件已完成更新后，再执行邮件发送逻辑。以下是两种可行实现方式：

方法1：检查文件最后修改时间 #

在Workbook_AfterSave事件中，等待文件的最后修改时间更新为保存后的时间，确保网络同步完成：

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    If Success Then ' 仅在保存成功时执行后续逻辑
        Dim filePath As String
        Dim lastModified As Date
        Dim waitTime As Integer
        
        filePath = "\\network\data\!Daily\11_Daily_Dashboard.xlsm"
        lastModified = FileDateTime(filePath)
        waitTime = 0
        
        ' 等待文件修改时间更新，最多等待30秒（可根据网络速度调整）
        Do While FileDateTime(filePath) = lastModified And waitTime < 30
            Application.Wait Now + TimeValue("00:00:01")
            waitTime = waitTime + 1
        Loop
        
        If waitTime < 30 Then ' 确认文件已完成更新
            Call Send_Email_with_Attachment
        Else
            ' 可选超时处理：提示或记录日志
            MsgBox "文件保存超时，邮件未发送"
        End If
    End If
End Sub

Sub Send_Email_with_Attachment()
    Dim MyOutlook As Object
    Set MyOutlook = CreateObject("Outlook.Application")

    Dim MyMail As Object
    Set MyMail = MyOutlook.CreateItem(0) ' 用数值0替代olMailItem，避免常量未定义问题

    MyMail.To = "example@email.com"
    MyMail.Subject = "Updated data"
    MyMail.Body = "File was updated" & " on " & Format(Now(), "mm-dd-yyyy") & " at " & Format(Now(), "hh:mm:ss AM/PM") & Chr(13) & Chr(13) & "You can find the file here:  \\network\data\!Daily "

    Attached_File = "\\network\data\!Daily\11_Daily_Dashboard.xlsm"
    MyMail.Attachments.Add Attached_File

    MyMail.Send
    
    ' 释放对象资源
    Set MyMail = Nothing
    Set MyOutlook = Nothing
End Sub

方法2：尝试独占锁定文件（更可靠） #

通过尝试以独占方式打开文件，验证文件是否已完成写入（能成功打开则说明保存完成）：

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    If Success Then
        Dim filePath As String
        Dim fileNum As Integer
        Dim waitTime As Integer
        Dim isFileReady As Boolean
        
        filePath = "\\network\data\!Daily\11_Daily_Dashboard.xlsm"
        waitTime = 0
        isFileReady = False
        
        Do While Not isFileReady And waitTime < 30
            On Error Resume Next
            fileNum = FreeFile()
            Open filePath For Binary Lock Read Write As #fileNum
            If Err.Number = 0 Then
                Close #fileNum
                isFileReady = True
            Else
                Err.Clear
                Application.Wait Now + TimeValue("00:00:01")
                waitTime = waitTime + 1
            End If
            On Error GoTo 0
        Loop
        
        If isFileReady Then
            Call Send_Email_with_Attachment
        Else
            MsgBox "文件保存超时，邮件未发送"
        End If
    End If
End Sub

Sub Send_Email_with_Attachment()
    Dim MyOutlook As Object
    Set MyOutlook = CreateObject("Outlook.Application")

    Dim MyMail As Object
    Set MyMail = MyOutlook.CreateItem(0)

    MyMail.To = "example@email.com"
    MyMail.Subject = "Updated data"
    MyMail.Body = "File was updated" & " on " & Format(Now(), "mm-dd-yyyy") & " at " & Format(Now(), "hh:mm:ss AM/PM") & Chr(13) & Chr(13) & "You can find the file here:  \\network\data\!Daily "

    Attached_File = "\\network\data\!Daily\11_Daily_Dashboard.xlsm"
    MyMail.Attachments.Add Attached_File

    MyMail.Send
    
    ' 释放对象资源
    Set MyMail = Nothing
    Set MyOutlook = Nothing
End Sub

关键说明 #

• 两种方法均设置30秒超时上限，避免无限等待，可根据实际网络速度调整该值。
• 方法2的文件锁定方式可靠性更高，直接验证文件是否可被独占访问，确保写入操作已完成。
• 原代码中olMailItem替换为数值0，避免因未引用Outlook库导致的常量未定义错误。
• 邮件发送完成后添加对象释放语句，避免内存占用。

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