Tengo una macro para enviar correos pero no manda nada

Tengo una macro que mandaba correos de forma masiva, sin embargo se ejecuta pero ya no manda nada me podrían ayudar.

Tengo office 365 y este error ocurrió despumes de la ultima actualización
Dejo el código

Sub correo_1()
Dim mi_App As Object
Dim mi_Correo As Object
    i = 1
    Do
      i = i + 1
    Set mi_App = CreateObject("Outlook.Application")
    mi_App.Session.logon
    Set mi_Correo = mi_App.CreateItem(0)
    ActiveWorkbook.Save
    On Error Resume Next
    With mi_Correo
    .SentOnBehalfOfName = "[email protected]"
    .To = Range("B" & i).Value
    .CC = Range("C" & i).Value
    .BCC = Range("D" & i).Value
    .Subject = Range("E" & i).Value
    .Body = Range("F" & i).Value
    .Attachments.Add Range("G" & i).Value
    .Attachments.Add Range("H" & i).Value
    .DeleteAfterSubmit = False
    .Send
    End With
    'MsgBox "Email enviado con éxito"
    On Error GoTo 0
    Set mi_Correo = Nothing
    Set mi_App = Nothing
 Loop Until i = 3
End Sub