Emails sent via Outlook using VBA stuck in outbox

Question

I'm attempting to send out emails with attachments via Outlook (initiated on Excel). The code runs without error but only about 6 of the 17 emails go out, the balance are stuck in outbox and go out when I open Outlook and sync the folders myself.

I've attempted using: DoEvents and Application.Wait (Now + TimeValue("0:00:03")) to no avail.

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

See adjustments to code. Move your initialization of the Outlook application outside the loop. You shouldn't be opening and closing these over and over and per your previous comment this is actually causing some issues, its possible that opening and closing the client successively is causing issues with the sync.

Option 1 - Move Outlook create outside loop

Moving the initilization outside the loop MIGHT fix your issue. If it doesn't, try option 2.

Option 2 - Forcibly initiate sync of "All Accounts" sync group

After all processing is complete we'll grab the sync groups using:

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

Then we'll kick of sync for group 1, usually "All Accounts".

mySyncObjects(1).Start

If this isn't "All Accounts" you'll need to loop through mySyncObjects to find it, using the property .Name

Adjusted code(note if to check for sending emails):

'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