问仅当电子邮件有附件时才运行
EN

Stack Overflow用户

提问于 2021-09-06 14:22:56

回答 1查看 111关注 0票数 0

我想运行以下代码，当一个特定的主题出现在电子邮件中。

此外，仅当该电子邮件有附件时才运行。

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

vba

outlook

attachment

email-attachments

回答 1

Stack Overflow用户

发布于 2021-11-13 16:17:06

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

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