Office365下Outlook VBA添加打开文件附件触发运行时错误

这个错误代码80070020对应的是文件被其他进程占用锁定，Office 365对文件权限的管控比Office 2016更严格，当目标文件处于打开状态时，Outlook无法获取足够的读取权限，导致附件添加失败。

下面提供两种解决思路：

思路1：提前检测文件锁定状态，提示用户关闭 #

在添加附件前先判断文件是否被打开，如果是就弹出提示，让用户关闭后再执行操作。修改原代码中添加附件的部分：

If vAttachmentFullPath <> "" And Dir(vAttachmentFullPath) <> "" Then
    ' 检测文件是否被锁定
    Dim fileNum As Integer
    Dim isLocked As Boolean
    isLocked = False
    
    On Error Resume Next
    fileNum = FreeFile()
    Open vAttachmentFullPath For Input Lock Read As #fileNum
    Close #fileNum
    If Err.Number <> 0 Then
        isLocked = True
        MsgBox "文件 " & vAttachmentFullPath & " 正在被使用，请关闭后重试。", vbExclamation
    End If
    On Error GoTo 0
    
    ' 未锁定时才添加附件
    If Not isLocked Then
        .Attachments.Add vAttachmentFullPath
    End If
End If

思路2：复制打开的文件到临时目录，用临时文件作为附件 #

如果不想打扰用户关闭文件，可以先把打开的文件复制到系统临时文件夹，添加这个临时文件作为附件，邮件发送完成后自动删除临时文件。修改后的完整代码如下：

Sub Email(Optional vToAddress As String, Optional vSubject As String, Optional vEmailRange As String = "", Optional vCCAddress As String, Optional vBCCAddress As String = "", Optional vAttachmentFullPath As String)

    Dim OutApp As Object
    Dim OutMail As Object
    Dim olInsp As Object
    Dim xlSheet As Worksheet
    Dim wdDoc As Object
    Dim oRng As Object
    Dim tempFilePath As String
    Dim fileExt As String
        
    If vEmailRange <> "" Then
        Application.GoTo Range(vEmailRange)
        Selection.Copy
    End If
    
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo 0
        
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = vToAddress
        If vCCAddress <> "" Then .CC = vCCAddress
        If vBCCAddress <> "" Then .BCC = vBCCAddress
        .Subject = vSubject
        .BodyFormat = olFormatHTML
        '.HTMLBody = ""
        If vAttachmentFullPath <> "" And Dir(vAttachmentFullPath) <> "" Then
            ' 判断文件是否被锁定
            Dim fileNum As Integer
            Dim isLocked As Boolean
            isLocked = False
            
            On Error Resume Next
            fileNum = FreeFile()
            Open vAttachmentFullPath For Input Lock Read As #fileNum
            Close #fileNum
            If Err.Number <> 0 Then
                isLocked = True
                ' 生成临时文件路径
                fileExt = Mid(vAttachmentFullPath, InStrRev(vAttachmentFullPath, "."))
                tempFilePath = Environ("TEMP") & "\temp_attach_" & Format(Now, "YYYYMMDDHHMMSS") & fileExt
                ' 复制原文件到临时目录
                FileCopy vAttachmentFullPath, tempFilePath
                ' 添加临时文件作为附件
                .Attachments.Add tempFilePath
            Else
                ' 文件未打开，直接添加原文件
                .Attachments.Add vAttachmentFullPath
            End If
            On Error GoTo 0
        End If
            
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
            
        If vEmailRange <> "" Then
            oRng.Collapse 1
            oRng.Paste
        End If
           
        .Display
        .Send
    End With
    
    ' 清理临时文件
    If tempFilePath <> "" And Dir(tempFilePath) <> "" Then
        Kill tempFilePath
    End If
       
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Application.CutCopyMode = False

End Sub

额外说明 #

• 思路2中，如果邮件发送失败，临时文件可能会留在系统临时目录里，可以根据需求添加错误捕获逻辑来确保临时文件被清理。
• 要确保当前用户有系统临时目录的读写权限，否则复制文件操作会失败。

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