VBA Loop to next, если в электронном письме нет прикрепленного файла - PullRequest
Новая
       18

VBA Loop to next, если в электронном письме нет прикрепленного файла

0 голосов
/ 23 мая 2019

У меня есть приведенный ниже код, который я использую для отправки массовых писем разным получателям и с двумя разными вложениями (один PDF и один Excel прикрепляются к каждому письму, когда доступно).Проблема в том, что когда макрос не находит PDF или Excel, который он должен прикрепить, он отправляет электронное письмо без каких-либо вложений, что плохо для меня :) Я хотел бы, чтобы этот код пропускал / удалял электронные письма, когда вложение не найдено.Если он находит только PDF или только Excel, то все в порядке, он уже вложил только то, что находит, но мне действительно нужно было бы перейти к следующему письму без отправки текущего, если текущее не имеет вложений 

Option Explicit
Public Sub SendScorecards()
   Dim olApp As Object
   Dim olMail As Object
   Dim olRecip As Object
   Dim olAtmt As Object
   Dim olAtmt2 As Object
   Dim iRow As Long
   Dim Recip As String
   Dim Subject As String
   Dim Atmt As String
   Dim Atmt2 As String

   iRow = 2

   Set olApp = CreateObject("Outlook.Application")
   Dim Sht As Worksheet
   Set Sht = ThisWorkbook.Worksheets("Sender")

   Do Until IsEmpty(Sht.Cells(iRow, 1))

      Recip = Sht.Cells(iRow, 1).Value 'Email addresses
      Subject = Sht.Cells(iRow, 2).Value 'Subject of the email, like "UK_Vendor name_Operations Scorecard"
      Atmt = Sht.Cells(iRow, 3).Value 'PDF attachment path
      Atmt2 = Sht.Cells(iRow, 4).Value 'Excel attachment path

      Set olMail = olApp.CreateItem(0)

      With olMail

         Set olRecip = .Recipients.Add(Recip)
        .Subject = Subject
        .Body = Sht.Cells.Range("J2") 'Blurb to be added in the body of the emails
        .Display
        Set olAtmt = .Attachments.Add(Atmt)
        Set olAtmt2 = .Attachments.Add(Atmt2)
         olRecip.Resolve
        .Send

      End With
    On Error Resume Next
      iRow = iRow + 1

   Loop

   Set olApp = Nothing
End Sub

1 Ответ

0 голосов
/ 23 мая 2019

Вы должны проверить, существуют ли файлы вложений.Смотрите этот ответ .Затем вы можете решить, отправлять или не отправлять электронные письма.

Вот как должен выглядеть ваш код (только цикл Do, вам нужно сохранить код до и после цикла без изменений).Я добавил оператор if, который пропускает строки, в которых не существует обоих файлов вложений, или, что то же самое, отправляет электронное письмо, если существует одно или оба вложения.Я не проверял этот код.Если он не запускается, дайте мне знать. 

Do Until IsEmpty(Sht.Cells(iRow, 1))

   Recip = Sht.Cells(iRow, 1).Value 'Email addresses
   Subject = Sht.Cells(iRow, 2).Value 'Subject of the email, like "UK_Vendor name_Operations Scorecard"
   Atmt = Sht.Cells(iRow, 3).Value 'PDF attachment path
   Atmt2 = Sht.Cells(iRow, 4).Value 'Excel attachment path

   If Dir(Atmt) <> "" Or Dir(Atmt2) <> "" Then

      Set olMail = olApp.CreateItem(0)
      With olMail
         Set olRecip = .Recipients.Add(Recip)
         .Subject = Subject
         .Body = Sht.Cells.Range("J2") 'Blurb to be added in the body of the emails
         .Display
         Set olAtmt = .Attachments.Add(Atmt)
         Set olAtmt2 = .Attachments.Add(Atmt2)
         olRecip.Resolve
         .Send
      End With

   End If

   On Error Resume Next
   iRow = iRow + 1
Loop
...