Outlook规则忽略附件检测条件 如何在VBA代码中添加邮件附件校验

你需要在代码入口处新增主题匹配校验、附件存在性校验，同时补充无符合要求Excel附件时的兜底退出逻辑，避免空值报错，修改后的完整代码如下，改动位置已加注释标注：

Public Sub SaveAttachmentsThenOpen(MItem As Outlook.MailItem)
    Dim oMail As Variant
    Dim oReply As Outlook.MailItem
    Dim oItems As Outlook.Items
    Dim Msg As Outlook.MailItem
    Dim oAttachment As Outlook.Attachment
    Dim StrBody As String
    Dim oRep As MailItem
    
    Dim sSaveFolder As String
    Dim Att As String
    Dim Attname As String
    Dim sht As Object
    Dim Rng As Range
    Dim s As String
    
    Dim myAttachments As Outlook.Attachments
    Dim XLApp As Object
    Dim XlWK As Object
    Dim strPaste  As Variant
    Dim oApp As Outlook.Application
    Dim oNs As Namespace
    
    '----------新增校验逻辑开始----------
    ' 替换为你需要匹配的指定主题
    Const TARGET_SUBJECT As String = "你的指定邮件主题"
    ' 校验1：主题是否匹配，当前为包含匹配，需要完全匹配可修改为 = TARGET_SUBJECT
    If InStr(1, MItem.Subject, TARGET_SUBJECT, vbTextCompare) = 0 Then
        Exit Sub
    End If
    ' 校验2：是否存在附件
    If MItem.Attachments.Count = 0 Then
        Exit Sub
    End If
    '----------新增校验逻辑结束----------
     
    Set oApp = New Outlook.Application
    Set oNs = oApp.GetNamespace("MAPI")
        
    Set XLApp = CreateObject("Excel.Application")
    With XLApp
        .Visible = True
        .ScreenUpdating = True
        .Workbooks.Open ("C:\Directory\data.xlsx")
        .Workbooks.Open ("C:\Directory\WB.xlsb")
    End With

    Dim strText As String
    strText = ".xls"
    sSaveFolder = "C:\Directory\TPS_Reports\"

    For Each oAttachment In MItem.Attachments
        If InStr(1, oAttachment.FileName, strText) > 0 Then
            oAttachment.SaveAsFile sSaveFolder & oAttachment.FileName
            Attname = oAttachment.FileName
            Att = sSaveFolder & oAttachment.FileName
            Exit For
        End If
    Next oAttachment
    Set oAttachment = Nothing
    
    '----------新增兜底校验：未找到符合要求的Excel附件直接退出----------
    If Att = "" Then
        ' 退出前释放Excel资源，避免后台残留进程
        XLApp.DisplayAlerts = False
        XLApp.Quit
        Set XLApp = Nothing
        Set oNs = Nothing
        Set oApp = Nothing
        Exit Sub
    End If
    
    XLApp.Workbooks.Open (Att)
    XLApp.Visible = True
    XLApp.Run ("WB.XLSB!MacroName")
    
    Set sht = XLApp.Workbooks(Attname).ActiveSheet
    
    Set Rng = sht.UsedRange
    
    s = "<table border=1 bordercolor=black cellspacing=0>"
    For rw = Rng.Row To Rng.Rows.Count
        s = s & "<tr>"
        For col = Rng.Column To Rng.Columns.Count
            s = s & "<td>" & sht.Cells(rw, col) & "</td>"
        Next
        s = s & "</tr>"
    Next
    s = s & "</table>"

    Set oRep = MItem.ReplyAll

    With oRep
        StrBody = "Hello"
        .HTMLBody = s
        .Send
    End With

    With XLApp
        .DisplayAlerts = False
    End With
    
    XLApp.Workbooks(Attname).Save
    XLApp.Quit

    With XLApp
        .DisplayAlerts = True
    End With
    
    ' 补充资源释放
    Set XLApp = Nothing
    Set oNs = Nothing
    Set oApp = Nothing
        
End Sub

修改说明 #

• 入口处的双重校验会直接拦截主题不匹配、无附件的邮件，不会执行后续逻辑
• 新增了Excel附件匹配失败的兜底逻辑，避免因无符合格式的附件导致打开空路径报错
• 补充了所有异常分支下的Excel进程、Outlook对象释放逻辑，避免后台残留无效进程

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