使用 VBA 通过 Outlook 发送的电子邮件卡在发件箱中

Question

我正在尝试通过 Outlook（在 Excel 上启动）发送带有附件的电子邮件。代码运行没有错误，但 17 封电子邮件中只有大约 6 封发送出去，余额卡在发件箱中，当我打开 Outlook 并自己同步文件夹时发送出去。

我尝试使用：DoEvents 和 Application.Wait (Now + TimeValue("0:00:03")) 无济于事。

For counter = 2 To 18

    branchCode = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("C" & counter).Value

    BranchName = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("A" & counter).Value
    branchEmail = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("D" & counter).Value
    sheetPath = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("J2").Value
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next

    With OutMail
        .To = branchEmail
        .BCC = ""
        .Subject = "Rate Sheet " & BranchName & " - " & Now()
        .Body = "Hi, Please find attached below your rate sheet, your uploads are ready as well."
        .Attachments.Add (sheetPath & BranchName & ".pdf")
        .Send
    End With
    On Error GoTo 0
    Application.Wait (Now + TimeValue("0:00:03"))
    Set OutMail = Nothing
    Set OutApp = Nothing

Next counter

Answer 1

查看代码调整。将 Outlook 应用程序的初始化移到循环之外。您不应该一遍又一遍地打开和关闭这些，并且根据您之前的评论，这实际上会导致一些问题，连续打开和关闭客户端可能会导致同步问题。

选项 1 - 移动 Outlook 创建外部循环

将初始化移到循环之外可能会解决您的问题。如果没有，请尝试选项 2。

选项 2 - 强制启动“所有帐户”同步组的同步

所有处理完成后，我们将使用以下方法获取同步组：

mySyncObjects = OutApp.GetNamespace("MAPI").SyncObjects

然后我们将启动第 1 组的同步，通常是“所有帐户”。

mySyncObjects(1).Start

如果这不是“所有帐户”，您需要循环通过 mySyncObjects 来找到它，使用属性 .Name

调整代码（注意是否检查发送电子邮件）：

'determine if you need to send emails
If needToSendEmails = 1 Then

Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")

For counter = 2 To 18



    branchCode = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("C" & counter).Value

    BranchName = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("A" & counter).Value
    branchEmail = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("D" & counter).Value
    sheetPath = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("J2").Value

    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = branchEmail
        .BCC = ""
        .Subject = "Rate Sheet " & BranchName & " - " & Now()
        .Body = "Hi, Please find attached below your rate sheet, your uploads are ready as well."
        .Attachments.Add (sheetPath & BranchName & ".pdf")
        .Send
    End With
    On Error GoTo 0
    ''This shouldn't be neccessary. I utilizie similar code to send 100+ emails quickly.  It takes a second for outlook to update but all should appear inside the app when processing complete.
    ''Application.Wait (Now + TimeValue("0:00:03")) 
    Set OutMail = Nothing


Next counter
''GET ALL SYNC GROUPS
Set mySyncObjects = OutApp.GetNamespace("MAPI").SyncObjects

''KICK OFF SYNC FOR ITEM 1 IN SYNC GROUPS, USUALLY ALL ACCOUNTS - MAY NEED TO LOOP THROUGH ALL SYNC GROUPS TO FIND "ALL ACCOUNTS"
mySyncObjects(1).Start

Set OutApp = Nothing

End If