Outlook отправляет не все письма кодом VBA - почему и как исправить?

На моем сайте есть несколько статей, посвященных отправке писем через Outlook:
Как отправить письмо из Excel?
Вставить в письмо Outlook таблицу Excel с форматированием
Вставить в письмо подпись из Outlook через VBA
Как отправить письмо от другой учетной записи Outlook

В большинстве случаев все работает корректно, но иногда письма "не отправляются". Если говорить точнее – не успевают отправиться и висят в папке Исходящие. Сначала разберемся почему так может происходить(очевидную причину неверно указанного адреса рассматривать не будем). Как правило это происходит при массовой рассылке, когда необходимо отправить много писем, перед отправкой Outlook закрыт и открывается специально для рассылки кодом. А по завершении работы кода Outlook закрывается, не дожидаясь вообще ничего. Пример подобного кода - рассылка 99 писем на основании значений ячеек:

Sub Send_Mail()
    Dim lr As Long
    Dim objOutlookApp As Object, objMail As Object
 
    Application.ScreenUpdating = False
    On Error Resume Next
    'подключаемся к Outlook
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    'отправка писем по значениям ячеек(со 2-ой до 100-ой)
    For lr = 2 To 100
        Set objMail = objOutlookApp.CreateItem(0)
        'если возникла ошибка при создании письма – завершаем процедуру
        If Err.Number <> 0 Then
            Set objOutlookApp = Nothing
            Set objMail = Nothing
            Exit Sub
        End If
        'создаем письмо, назначаем адресата, текст и тему
        With objMail
            .To = Cells(lr, 1).Value
            .Subject = Cells(lr, 2).Value
            .Body = Cells(lr, 3).Value
            .Send 'отправляем
        End With
    Next
    'завершаем работу - очищаем объекты
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

И именно здесь и кроется проблема: если письма достаточно объемные, содержат вложения или картинки или просто интернет медленный – то такие письма отправляться могут значительно дольше. И некоторые письма Outlook просто не успевает отправить до его принудительного закрытия кодом(если быть точнее – выгрузки из памяти объекта Outlook по завершении процедуры).
Письма, конечно, в итоге всё равно будут отправлены – при следующем запуске Outlook. Но как сделать, чтобы Outlook отправил все письма сразу? Варианта два:

Открывать Outlook вручную перед рассылкой. Т.к. мы определились, что сама проблема именно в том, что Outlook закрывается, не дождавшись отправки. Если на момент запуска кода он будет открыт - то и закрываться не будет. Решение надежное, но не очень правильное с точки зрения программирования. Ведь не будем же мы пользователям говорить: обязательно откройте Outlook перед работой кода? Конечно, если в контексте задачи это не проблема – то можно применить это решение. Например, на большинстве корпоративных ПК Outlook вообще не закрывается.
Добавить некую задержку в код перед завершением. Т.к. мы не уверены в том, сколько именно необходимо времени – то лучше задержку делать по проверке количества писем в папке Исходящие и не завершать код до тех пор, пока в папке Исходящие есть хоть одно письмо:

Sub Send_Mail()
    Dim lr As Long
    Dim objOutlookApp As Object, objMail As Object
 
    Application.ScreenUpdating = False
    On Error Resume Next
    'подключаемся к Outlook
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    'отправка писем по значениям ячеек(со 2-ой до 100-ой)
    For lr = 2 To 100
        Set objMail = objOutlookApp.CreateItem(0)
        'если возникла ошибка при создании письма – завершаем процедуру
        If Err.Number <> 0 Then
            Set objOutlookApp = Nothing
            Set objMail = Nothing
            Exit Sub
        End If
        'создаем письмо, назначаем адресата, текст и тему
        With objMail
            .To = Cells(lr, 1).Value
            .Subject = Cells(lr, 2).Value
            .Body = Cells(lr, 3).Value
            .Send 'отправляем
        End With
    Next
 
    'подключаемся к папке Исходящие
    Dim oNSpace As Object, oSending As Object
    Set oNSpace = objOutlookApp.GetNamespace("MAPI")
    Set oSending = oNSpace.GetDefaultFolder(4) 'Исходящие
 
    'дожидаемся полной отправки всех писем, отслеживая папку Исходящие
    Do While oSending.Items.Count > 0
        DoEvents
    Loop
    'завершаем работу - очищаем объекты
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Решение отличное, но требуется учесть и еще один нюанс: вдруг в момент отправки отключили интернет? Программа будет работать до "посинения" или пока нам не вернут доступ в сеть. Поэтому мы добавим в код еще одну проверку – на лимит времени ожидания. Пусть это будет 5 минут(это время всегда можно поменять под свои задачи). Тогда код будет выглядеть так:

Sub Send_Mail()
    Dim lr As Long
    Dim objOutlookApp As Object, objMail As Object
 
    Application.ScreenUpdating = False
    On Error Resume Next
    'подключаемся к Outlook
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    'отправка писем по значениям ячеек(со 2-ой до 100-ой)
    For lr = 2 To 100
        Set objMail = objOutlookApp.CreateItem(0)
        'если возникла ошибка при создании письма – завершаем процедуру
        If Err.Number <> 0 Then
            Set objOutlookApp = Nothing
            Set objMail = Nothing
            Exit Sub
        End If
        'создаем письмо, назначаем адресата, текст и тему
        With objMail
            .To = Cells(lr, 1).Value
            .Subject = Cells(lr, 2).Value
            .Body = Cells(lr, 3).Value
            .Send 'отправляем
        End With
    Next
 
    'подключаемся к папке Исходящие
    Dim oNSpace As Object, oSending As Object, iTimer
    Set oNSpace = objOutlookApp.GetNamespace("MAPI")
    Set oSending = oNSpace.GetDefaultFolder(4) 'Исходящие
 
    'дожидаемся полной отправки всех писем, отслеживая папку Исходящие
    'запоминаем время начала отслеживания папки Исходящие
    iTimer = Timer
    Do While oSending.Items.Count > 0
        DoEvents
        'проверяем сколько времени прошло
        'если более 5 минут - завершаем код
        If Format((Timer - iTimer) / 86400, "Long time") >= "0:05:00" Then
            Exit Do
        End If
    Loop
    'завершаем работу - очищаем объекты
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Sub Send_Mail() Dim lr As Long Dim objOutlookApp As Object, objMail As Object Application.ScreenUpdating = False On Error Resume Next 'подключаемся к Outlook Set objOutlookApp = GetObject(, "Outlook.Application") Err.Clear If objOutlookApp Is Nothing Then Set objOutlookApp = CreateObject("Outlook.Application") End If 'отправка писем по значениям ячеек(со 2-ой до 100-ой) For lr = 2 To 100 Set objMail = objOutlookApp.CreateItem(0) 'если возникла ошибка при создании письма – завершаем процедуру If Err.Number <> 0 Then Set objOutlookApp = Nothing Set objMail = Nothing Exit Sub End If 'создаем письмо, назначаем адресата, текст и тему With objMail .To = Cells(lr, 1).Value .Subject = Cells(lr, 2).Value .Body = Cells(lr, 3).Value .Send 'отправляем End With Next 'подключаемся к папке Исходящие Dim oNSpace As Object, oSending As Object, iTimer Set oNSpace = objOutlookApp.GetNamespace("MAPI") Set oSending = oNSpace.GetDefaultFolder(4) 'Исходящие 'дожидаемся полной отправки всех писем, отслеживая папку Исходящие 'запоминаем время начала отслеживания папки Исходящие iTimer = Timer Do While oSending.Items.Count > 0 DoEvents 'проверяем сколько времени прошло 'если более 5 минут - завершаем код If Format((Timer - iTimer) / 86400, "Long time") >= "0:05:00" Then Exit Do End If Loop 'завершаем работу - очищаем объекты Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = True End Sub

Теперь отправка будет работать при любых условиях максимально корректно.

Единственное, на что стоит обратить особое внимание: не всегда может быть так, что папка Исходящие имеет номер 4 - oNSpace.GetDefaultFolder(4).
Порядок папок на некоторых ПК может отличаться(как правило это либо на серверных версиях, либо вследствие вмешательства в структуру папок). Поэтому, если код из статьи не работает "as is"- можно попробовать найти папку Исходящие следующим кодом:
Sub FindOutcomingFolder()
    Dim objOutlApp As Object, oNSpace As Object, i As Long
    On Error Resume Next
    Set objOutlApp = GetObject(, "outlook.Application")
    If objOutlApp Is Nothing Then
        Set objOutlApp = CreateObject("outlook.Application")
    End If
    Set oNSpace = objOutlApp.GetNamespace("MAPI")
    For i = 1 To 50
        MsgBox i & " = " & oNSpace.GetDefaultFolder(i)
    Next
End Sub
Sub FindOutcomingFolder() Dim objOutlApp As Object, oNSpace As Object, i As Long On Error Resume Next Set objOutlApp = GetObject(, "outlook.Application") If objOutlApp Is Nothing Then Set objOutlApp = CreateObject("outlook.Application") End If Set oNSpace = objOutlApp.GetNamespace("MAPI") For i = 1 To 50 MsgBox i & " = " & oNSpace.GetDefaultFolder(i) Next End Sub
Тогда достаточно будет запустить код и посмотреть какому номеру в показываемых сообщениях соответствует папка Исходящие(Outcoming).