Добавление статуса отправки электронной почты в Excel

Question

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

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

Sub SendEmails() 

    Dim answer As Variant 

    answer = MsgBox("You are about to send the statements. Proceed?", vbYesNo + vbQuestion, "Alert") 

    Select Case answer 
    Case vbYes 

    MsgBox "Process may take a while to finish. Do not attempt to close the worksheet or Outlook.", vbInformation, "Alert" 

    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim sh As Worksheet 
    Dim cell As Range 
    Dim FileCell As Range 
    Dim rng As Range 

    With Application 
     .EnableEvents = False 
     .ScreenUpdating = False 
    End With 

    Set sh = Sheets("Listing") 

    Set OutApp = CreateObject("Outlook.Application") 

    For Each cell In sh.Columns("D").Cells.SpecialCells(xlCellTypeConstants) 

     Set rng = sh.Cells(cell.Row, 1).Range("A1:B1") 

     If cell.Value Like "?*@?*.?*" And _ 
      Application.WorksheetFunction.CountA(rng) > 0 Then 
      Set OutMail = OutApp.CreateItem(0) 

      With OutMail 
       .to = cell.Value 
       .Subject = "Statement of Account - " & cell.Offset(0, 2).Value 
       .Body = cell.Offset(0, 1).Value 

       For Each FileCell In rng.SpecialCells(xlCellTypeConstants) 
        If Trim(FileCell) <> "" Then 
         If Dir(FileCell.Value) <> "" Then 
          .Attachments.Add FileCell.Value 
         End If 
        End If 
       Next FileCell 

       .Send 'Or use .Display 
      End With 

      Set OutMail = Nothing 
     End If 
    Next cell 

    Set OutApp = Nothing 
    With Application 
     .EnableEvents = True 
     .ScreenUpdating = True 
    End With 

    Case vbNo 
GoTo Quit: 
    End Select 

Quit: 

End Sub 

Answer 1

Почему просто не Resolve электронной почты каждого получателя перед отправкой

например:

For Each olRecip In .Recipients 
      olRecip.Resolve 
     If Not olRecip.Resolve Then 
      olMsg.Display 
     End If