Outlook VBA自动化问题：等待安全扫描与Exchange发件人识别

问题背景 #

已实现通过邮件附件导入数据到主文件的功能，无安全扫描时脚本运行正常，但遇到以下两个问题：

• 公司新附件会触发安全扫描，脚本执行时因扫描未完成导致文件无法保存，提示文件名错误，需实现等待扫描完成后再执行后续操作。
• 用「邮件主题+发件人邮箱」识别邮件时，Exchange环境下常规邮箱地址（如Name.Surname@Company.com）在代码中无效，无法准确区分发件人。

解决方案 #

问题1：等待安全扫描完成再执行 #

通过循环检查文件是否可写入的方式，等待安全扫描结束。核心逻辑是尝试以写入锁的方式打开文件，成功则说明扫描完成；失败则暂停一段时间后重试，直到超时或成功。

问题2：获取Exchange环境下的准确发件人地址 #

Exchange环境中，SenderEmailAddress返回的是内部格式地址（如/O=ORGANIZATION/OU=EXCHANGE ADMINISTRATIVE GROUP...），需通过Sender.GetExchangeUser().PrimarySmtpAddress获取真实的SMTP邮箱地址。同时兼容外部邮箱场景，外部邮箱可直接使用SenderEmailAddress。

修改后的完整VBA代码 #

Private Sub olItems_ItemAdd(ByVal item As Object)
    '变量声明
    Dim olMail As Outlook.MailItem
    Dim olAtt As Outlook.Attachment
    Dim Dateipfad As String
    Dim maxRetries As Integer
    Dim retryCount As Integer
    Dim fileUnlocked As Boolean
    Dim fNum As Integer
    
    '检查是否为邮件对象
    If TypeName(item) = "MailItem" Then
        Set olMail = item
        
        '筛选目标邮件：主题匹配+发件人SMTP地址验证
        If InStr(olMail.Subject, "Auswertung Pickleistung und Bedarfe") <> 0 Then
            '获取发件人真实SMTP地址
            Dim senderSMTP As String
            On Error Resume Next
            If Not olMail.Sender Is Nothing Then
                If olMail.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
                    senderSMTP = olMail.Sender.GetExchangeUser().PrimarySmtpAddress
                Else
                    senderSMTP = olMail.SenderEmailAddress
                End If
            End If
            On Error GoTo 0
            
            '匹配目标发件人
            If senderSMTP = "patrick.staniczek@firmenname.com" Then
                '遍历所有附件
                For Each olAtt In olMail.Attachments
                    Dateipfad = "Z:\Administration\Controlling\Controlling\MWZ\05_Lagerkennzahlen\" & olAtt.Filename
                    
                    '保存附件
                    olAtt.SaveAsFile Dateipfad
                    
                    '等待文件解锁（安全扫描完成）
                    maxRetries = 20 '最大重试次数，可按需调整
                    retryCount = 0
                    fileUnlocked = False
                    
                    Do While retryCount < maxRetries And Not fileUnlocked
                        retryCount = retryCount + 1
                        On Error Resume Next
                        fNum = FreeFile()
                        Open Dateipfad For Write Lock Read Write As #fNum
                        Close #fNum
                        If Err.Number = 0 Then
                            fileUnlocked = True
                        Else
                            Err.Clear
                            Application.Wait Now + TimeValue("00:00:02") '每次等待2秒，可按需调整
                        End If
                        On Error GoTo 0
                    Loop
                    
                    '文件解锁后执行数据导入
                    If fileUnlocked Then
                        Call Auswertung_Pickleistung_und_Bedarfe(Dateipfad)
                    Else
                        Debug.Print "文件 " & Dateipfad & " 超时未解锁，跳过处理"
                    End If
                Next olAtt
                
                '调试输出
                Debug.Print olMail.Subject
                Debug.Print "发件人SMTP地址：" & senderSMTP
                Debug.Print "附件数量：" & olMail.Attachments.Count
            End If
        End If
    End If
End Sub

代码关键说明 #

• 等待扫描逻辑：通过Open语句尝试锁定文件，成功则确认扫描完成；失败则等待2秒后重试，最多重试20次，避免无限等待。
• 发件人地址兼容：区分Exchange内部用户和外部用户，内部用户获取真实SMTP地址，外部用户直接使用原生地址，避免判断失效。
• 路径修正：在附件保存路径末尾添加反斜杠，避免文件名与路径拼接错误。

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