Письма, отправленные через Outlook с использованием VBA, застряли в папке «Исходящие»

Question

Я пытаюсь отправить электронные письма с вложениями через Outlook (инициировано в Excel). Код выполняется без ошибок, но только около 6 из 17 электронных писем уходят, баланс остается в исходящих и исчезает, когда я открываю 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