Отправляйте только те электронные письма, которые имеют вложения, с помощью кода VBA - PullRequest
Новая
       8

Отправляйте только те электронные письма, которые имеют вложения, с помощью кода VBA

0 голосов
/ 01 мая 2018

Я только начал работать над макросами и пока добился довольно приличного прогресса.

Однако я застрял в каком-то месте и не могу найти на него ответ.

Я использую макрос для отправки писем конкретным получателям через outlook. Я отправляю несколько вложений Excel и PDF в каждом письме.

Код работает фантастически! Тем не менее, мне нужно добавить условие, при котором электронное письмо, которое не имеет вложений EXCEL, не отправляется, и почтовый элемент outlook create для этого конкретного случая закрывается только автоматически.

Остальная часть макроса должна продолжаться для других клиентов с вложениями Excel.

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

Sub SendEmailWithReview_R()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim X As Long

    Lastrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row

    For X = 10 To Lastrow
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(olmailitem)

        With OutMail
            .To = Cells(X, 4)
            .CC = Cells(X, 6)
            .Subject = Cells(X, 8)
            .Body = Cells(1, 8)

            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & Cells(X, 1) & "-OICR.xlsx"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & Cells(X, 1) & "-OICLR.xlsx"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & "OIC - Bank Details" & ".pdf"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & "OICL - Bank Details" & ".pdf"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            .Display
            'send
        End With  
    Next X
End Sub

Ответы [ 2 ]

0 голосов
/ 03 мая 2018

Чтобы добавить условие, чтобы проверить, имеет ли OutMail приложение Excel, просто замените следующее 

       .Display
        'send

С этими кодами 

Dim Atmt As Object
For Each Atmt In OutMail.Attachments

    Dim sFileType As String
    sFileType = LCase$(Right$(Atmt.fileName, 4)) ' Last 4 Char in Filename
    Debug.Print Atmt.fileName

    Select Case sFileType
        Case ".xls", "xlsx"

         .Display
        '.send

    End Select
Next
0 голосов
/ 02 мая 2018

Так что вместо того, чтобы ждать ошибок или пытаться их подавить, лучше проверить, существует ли файл. Поэтому вы можете использовать такую ​​функцию, которая возвращает true, если файл существует: 

Public Function FileExists(FilePath As String) As Boolean
    Dim Path As String

    On Error Resume Next
    Path = Dir(FilePath)
    On Error GoTo 0

    If Path <> vbNullString Then FileExists = True
End Function

Для добавления вложений я рекомендую использовать массив для имен файлов, чтобы вы могли легко просматривать и прикреплять файлы, если они существуют. Каждый раз, когда мы добавляем вложение, мы также увеличиваем AttachedFilesCount.

Таким образом, вы не используете On Error Resume Next неправильно и не сталкиваетесь с проблемами отладки из-за этого. Итак, у вас есть чистый раствор. 

With OutMail
    .To = Cells(X, 4)
    .CC = Cells(X, 6)
    .Subject = Cells(X, 8)
    .Body = Cells(1, 8)

    Dim FileLocations As Variant
    FileLocations = Array("C:\Users\HKhan\Desktop\Final Macro\" & Cells(X, 1) & "-OICR.xlsx", _
                          "C:\Users\HKhan\Desktop\Final Macro\" & Cells(X, 1) & "-OICLR.xlsx", _
                          "C:\Users\HKhan\Desktop\Final Macro\" & "OIC - Bank Details" & ".pdf", _
                          "C:\Users\HKhan\Desktop\Final Macro\" & "OICL - Bank Details" & ".pdf")

    Dim AttachedFilesCount As Long

    Dim FileLocation As Variant
    For Each FileLocation In FileLocations
        If FileExists(FileLocation) Then
            .Attachments.Add (FileLocation)
            AttachedFilesCount = AttachedFilesCount + 1
        End If
    Next FileLocation

    If AttachedFilesCount > 0 Then
        .Display 'display or send email
    Else
        .Close 'close it if no attachments
    End If

End With

Если вам по-прежнему требуется дополнительная обработка ошибок при добавлении вложений (лично я не думаю, что вам это нужно обязательно), вы можете реализовать это следующим образом: 

On Error Resume Next  'turn error reporting off
.Attachments.Add (FileLocation) 'the line where an error might possibly occur.
If Err.Number <> 0 Then 'throw a msgbox if there is an error
    MsgBox "Could not attach file """ & FileLocation & """ to the email." & vbCrLf & Err.Description, vbExclamation, "Error " & Err.Number, Err.HelpFile, Err.HelpContext
End If
On Error Goto 0 'turn error reporting on again!
...