Question

我有以下代码，用于将批量电子邮件发送给不同的收件人，并带有2个不同的附件（如果可用，每个邮件都附有一个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

Answer 1

您应该检查附件文件是否存在。参见此answer。然后，您可以决定是否发送电子邮件。

这是您的代码的外观（仅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

没有附件要添加到电子邮件时，VBA循环到下一个

1 个答案: