Блог

Главная - Вопросы по программированию - Запускайте только в том случае, если в электронном письме есть вложение

Запускайте только в том случае, если в электронном письме есть вложение

#vba #outlook #attachment #email-attachments

Вопрос:

Я хочу, чтобы приведенный ниже код запускался при появлении в электронном письме определенной темы
, а также запускался только в том случае, если в этом письме есть вложение.

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:Directorydata.xlsx")
        .Workbooks.Open ("C:DirectoryWB.xlsb")
    End With

    Dim strText As String
    strText = ".xls"
    sSaveFolder = "C:DirectoryTPS_Reports"

    For Each oAttachment In MItem.Attachments
        If InStr(1, oAttachment.FileName, strText) > 0 Then
            oAttachment.SaveAsFile sSaveFolder amp; oAttachment.FileName
            Attname = oAttachment.FileName
            Att = sSaveFolder amp; 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 amp; "<tr>"
        For col = Rng.Column To Rng.Columns.Count
            s = s amp; "<td>" amp; sht.Cells(rw, col) amp; "</td>"
        Next
        s = s amp; "</tr>"
    Next
    s = s amp; "</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

Комментарии:

1. Если вы не можете найти/получить ответ на superuser.com затем вы можете добавить If MItem.Attachments.Count = 0 Then Exit Sub в код.

2. Спасибо! Где это должно быть указано в коде??

3. @MarkFisher Добавление этой строки в качестве первой строки должно быть в порядке (ниже Public Sub SaveAttachmentsThenOpen(MItem As Outlook.MailItem) )

4. Я добавил в код, и он все еще работает неправильно. Когда я только что провел тест, книги Excel все еще открывались, а затем появилась ошибка, потому что в outlook не было вложения для открытия.

5. Правило считает, что есть привязанность. MItem.Attachments.Count не равно нулю. Вывод в том, что есть привязанность. Какая строка генерирует ошибку и что это за сообщение об ошибке?

Ответ №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
Метки: ,