仅在电子邮件有附件时运行答案

【问题标题】：Only run if email has attachment仅在电子邮件有附件时运行
【发布时间】：2021-11-03 21:50:48
【问题描述】：

我希望在电子邮件中出现特定主题时运行以下代码。
也仅在该电子邮件有附件时运行。

Outlook 会忽略规则的附件部分，并尝试运行代码，即使附件不存在（它似乎只关心主题）。

如何在代码中加入附件检查？

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
     
    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
    
    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
        
End Sub

【问题讨论】：

如果您在 superuser.com 上找不到/得到答案，那么您可以将 If MItem.Attachments.Count = 0 Then Exit Sub 添加到代码中。
谢谢！那应该放在代码的什么地方？？
@MarkFisher 将该行添加为第一行应该没问题（低于Public Sub SaveAttachmentsThenOpen(MItem As Outlook.MailItem)）
我在代码中添加了，但仍然无法正常工作。当我刚刚运行测试时，excel 工作簿仍然打开，然后出现错误，因为 Outlook 中没有要打开的附件。
规则认为有附件。 MItem.Attachments.Count 不为零。结论是有附件。哪一行产生错误，错误信息是什么？

标签： vba outlook attachment email-attachments

【解决方案1】：

在检查附件之前尝试等待邮件进入收件箱。

ThisOutlookSession 模块的代码

重新启动 Outlook 或手动运行 Application_Startup。

Private WithEvents myItems As Items

Private Sub Application_Startup()
    Dim myInbox  As folder
    
    Set myInbox = Session.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
End Sub

Private Sub myItems_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is mailItem Then
        If Item.Attachments.Count > 0 Then
            SaveAttachmentsThenOpen Item
        End If
    End If
End Sub


Private Sub test()
    myItems_ItemAdd ActiveInspector.currentItem
End Sub

【讨论】：