Outlook VBA下载指定邮件附件问题：发件人及主题判断失效求助

需求回顾 #

• 每日接收外部邮件：发件人Company Servicing <servicing_qa@Company.com>，主题格式为company servicing - YYYY-MM-DD reports
• 需下载邮件中的4个CSV附件到目录M:\Company\received
• 仅筛选当日收到的符合条件的邮件

现有代码问题分析 #

1. 主题判断失效：你用了固定日期的字符串"company servicing - 2023-06-13 reports"，无法适配每日变化的日期；且未判断InStr的返回值（需返回值>0才表示主题包含目标字符串）。
2. 发件人地址判断失效：外部邮件的SenderEmailAddress可能返回Exchange格式地址而非SMTP地址，直接用等于判断会不匹配。

修正后的完整VBA代码 #

Sub DownloadDailyServicingReports()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olMail As Outlook.MailItem
    Dim strFilter As String
    Dim strTargetSubject As String
    Dim strTargetSenderSMTP As String
    Dim strSavePath As String
    Dim att As Outlook.Attachment
    
    ' 初始化变量
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFldr = olNS.GetDefaultFolder(olFolderInbox)
    strSavePath = "M:\Company\received\"
    strTargetSenderSMTP = "servicing_qa@Company.com"
    ' 动态生成当日主题格式
    strTargetSubject = "company servicing - " & Format(Date, "yyyy-mm-dd") & " reports"
    
    ' 筛选当日收到的邮件（精确到当日0点）
    strFilter = "[ReceivedTime] >= '" & Format(Date, "ddddd") & "'"
    Set olItems = olFldr.Items.Restrict(strFilter)
    olItems.Sort "[ReceivedTime]", olDescending ' 按时间倒序，优先处理最新邮件
    
    ' 遍历筛选后的邮件
    For Each olMail In olItems
        If olMail.Class = olMail Then ' 确保是邮件项
            ' 1. 验证主题（忽略大小写）
            If InStr(1, olMail.Subject, strTargetSubject, vbTextCompare) > 0 Then
                ' 2. 验证发件人SMTP地址
                Dim senderSMTP As String
                On Error Resume Next ' 处理非Exchange发件人
                If olMail.SenderEmailType = "SMTP" Then
                    senderSMTP = olMail.SenderEmailAddress
                Else
                    senderSMTP = olMail.Sender.GetExchangeUser().PrimarySmtpAddress
                End If
                On Error GoTo 0
                
                If LCase(senderSMTP) = LCase(strTargetSenderSMTP) Then
                    ' 3. 下载CSV附件
                    If olMail.Attachments.Count > 0 Then
                        For Each att In olMail.Attachments
                            If Right(att.FileName, 4) = ".csv" Then
                                att.SaveAsFile strSavePath & att.FileName
                            End If
                        Next att
                        MsgBox "附件已成功下载至：" & strSavePath
                    End If
                End If
            End If
        End If
    Next olMail
    
    ' 释放对象
    Set att = Nothing
    Set olMail = Nothing
    Set olItems = Nothing
    Set olFldr = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

关键修正说明 #

• 动态主题生成：用Format(Date, "yyyy-mm-dd")自动生成当日日期，确保每日都能匹配正确主题。
• 发件人地址兼容处理：区分SMTP和Exchange发件人类型，获取真实的SMTP地址；用LCase统一小写避免大小写不匹配。
• InStr判断逻辑：增加返回值>0的判断，同时用vbTextCompare忽略大小写，提升鲁棒性。
• 邮件类型验证：增加olMail.Class = olMail判断，避免遍历到非邮件项（如会议邀请）。

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