Vba 将电子邮件发送状态添加到Excel

我使用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=MsgBox（“您将要发送声明。是否继续？”，vbYesNo+vbQuestion，“警报”）
选择案例答案
案例vbYes
MsgBox“进程可能需要一段时间才能完成。请勿尝试关闭工作表或Outlook。”，vbInformation，“警报”
Dim OutApp作为对象
将邮件变暗为对象
将sh设置为工作表
暗淡单元格作为范围
将文件单元设置为范围
变暗rng As范围
应用
.EnableEvents=False
.ScreenUpdate=False
以
Set sh=图纸（“列表”）
Set-OutApp=CreateObject（“Outlook.Application”）
对于sh.Columns（“D”）.Cells.SpecialCells（xlCellTypeConstants）中的每个单元格
设置rng=sh.Cells（cell.Row，1）.范围（“A1:B1”）
如果单元格值像“*@*。？*”和_
Application.WorksheetFunction.CountA（rng）>0则
Set-OutMail=OutApp.CreateItem（0）
发邮件
.to=单元格.Value
.Subject=“对账单-”&单元格偏移量（0,2）.值
.Body=单元偏移量（0,1）.Value
对于rng.SpecialCells中的每个文件单元（xlCellTypeConstants）
如果修剪（文件单元）”，则
如果Dir（FileCell.Value）“，则
.Attachments.Add FileCell.Value
如果结束
如果结束
下一个文件单元
.Send'或use.Display
以
发送邮件=无
如果结束
下一个细胞
设置应用程序=无
应用
.EnableEvents=True
.ScreenUpdate=True
以
案例vbNo
转到退出：
结束选择
退出：
端接头

为什么不在发送前解析每个收件人的电子邮件

例如：

---

您可能需要记住，除非启用此选项并且收件人愿意向您发送“已接收”通知（这要求收件人的电子邮件程序支持此选项），否则Outlook无法判断电子邮件是否已实际发送。Outlook也无法判断电子邮件地址是否无效。Outlook仍将尝试发送电子邮件，几分钟后，您可能会收到来自目标域的自动回复，告知收件人未知或无效。谢谢。事实上，我需要一个迹象，表明电子邮件是从我这边发出的；我真的不在乎他们是否被送到。由于我使用vba excel发送电子邮件，它将遍历整个列表并发送它们，因此我无法判断它是否由于电子邮件单元格空白而跳过了一行。

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