VBA Outlook - Operation Failed

Question

I made a macro in Outlook 2016 that runs as soon as a new email arrives.

But sometimes the screen appears below at the time the email arrives:

And if I ask the person to send a new email exactly like the one that caused the error or forward the same email or if I manually have the rule run for the messages in the inbox, the error does not appear again.

This is the only screen that error appears. No error appears in the lines of code during execution (because it does not even execute).

Below is the code used:

Public Sub enviarListaParceiras(Item As Outlook.MailItem)
    Dim strID As String
    Dim objMail As Outlook.MailItem
    Dim corpoEmail As String
    Dim assunto As String
    Dim de As String
    Dim mensagem As String
    Dim email As String
    Dim nomeEscola As String
    Dim idEscola As Long
    Dim excelApp As Excel.Application
    Dim obj_Connection As New ADODB.Connection
    Dim obj_RecordSet As New ADODB.Recordset
    Dim str_SQL As String
    Dim str_PlanilhaDestino As String
    Dim str_ConnString As String
    Dim str_LinhaInicial As String
    Dim nr_coluna As Integer
    Dim diaUltimaAtualizacao As String
    Dim horaUltimaAtualizacao As String
    Dim horaDoEmail As String
    Dim planilha As Workbook
    Dim nomeArquivo As String
    Dim nomeArquivo2 As String
    Dim dataArquivo As String
    Dim horaArquivo As String
    Dim horaParaPlanilha As String
    Dim dataParaPlanilha As String
    Dim saudacao As String
    Dim nomeEscolaAbreviado As String
    Dim nomeNovaPlanilha As String
    Dim FSO As FileSystemObject
    Dim nomeEnviado As String
    Dim atualizada As Boolean
    Dim grupo As Long
    Dim data, hora As String
    
    If Hour(Now) < 12 Then
        saudacao = "Bom dia!"
    ElseIf Hour(Now) > 11 And Hour(Now) < 18 Then
        saudacao = "Boa tarde!"
    ElseIf Hour(Now) > 17 Then
        saudacao = "Boa noite!"
    End If
    
    strID = Item.EntryID
    Set objMail = Application.Session.GetItemFromID(strID)
    corpoEmail = objMail.Body
    assunto = objMail.Subject
    grupo = CLng(Trim(Mid(assunto, InStr(1, assunto, ")") - 2, 2)))
    If InStr(1, assunto, "#atualizada") > 0 Or InStr(1, assunto, "#Atualizada") > 0 Then
        atualizada = True
    Else
        atualizada = False
    End If
    
    de = objMail.SenderEmailAddress
    If InStr(1, corpoEmail, "De:") <> 0 Then
        email = Mid(corpoEmail, InStr(1, corpoEmail, "De:") + 3, (InStr(1, corpoEmail, "Enviada em:") - 1) - (InStr(1, corpoEmail, "De:") + 3))
        If InStr(1, email, "<") <> 0 Then
            email = Mid(email, InStr(1, email, "<") + 1, ((InStr(1, email, ">") - 1) - InStr(1, email, "<")))
        End If
    End If
    horaDoEmail = objMail.ReceivedTime
    nomeEnviado = objMail.SenderName
    If email = "" Then
        email = de
    End If
    
    
    If atualizada = True Then
        Set excelApp = New Excel.Application
        excelApp.Visible = True
        Set planilha = excelApp.Workbooks.Open("[caminho da pasta]\tentativa 4.0.xlsm")
        With excelApp.Sheets("Principal")
            .Activate
            .Cells(3, "E") = "x"
            .Cells(5, "E") = "x"
        End With
        excelApp.DisplayAlerts = False
        excelApp.ScreenUpdating = False
        excelApp.Wait (Now + TimeValue("0:00:01"))
        On Error Resume Next
        excelApp.Run "'tentativa 4.0.xlsm'!principal"
        excelApp.Workbooks("tentativa 4.0.xlsm").Activate
        nomeNovaPlanilha = excelApp.Workbooks("tentativa 4.0.xlsm").Sheets("Principal").Cells(1, "M")
        excelApp.Workbooks("tentativa 4.0.xlsm").Save
        excelApp.Workbooks("tentativa 4.0.xlsm").Close
        excelApp.Quit
        nomeArquivo = ListaArquivos("[caminho da pasta]\Atual")
        Kill ("[caminho da pasta]\Atual\" & nomeArquivo)
        Set FSO = CreateObject("scripting.filesystemobject")
        Call FSO.CopyFile("[caminho da pasta]/" & nomeNovaPlanilha, "[caminho da pasta]/Atual/")
        nomeArquivo = ListaArquivos("[caminho da pasta]\Atual")
        data = Mid(nomeArquivo, 46, InStr(46, nomeArquivo, "_") - 46)
        hora = Mid(nomeArquivo, InStr(46, nomeArquivo, "_") + 1, InStr(1, nomeArquivo, ".") - InStr(46, nomeArquivo, "_"))
        hora = Left(hora, Len(hora) - 1)
        
        Set excelApp = New Excel.Application
        excelApp.DisplayAlerts = False
        excelApp.ScreenUpdating = False
        excelApp.Visible = True
        excelApp.Workbooks.Open ("[caminho da pasta]\Geração_ListaEspera_PARCEIRAS_2021_v2.6 - OUTLOOK.xlsm")
        excelApp.Wait (Now + TimeValue("0:00:01"))
        excelApp.Sheets("Seleção Escolas").Select
        DoEvents
        excelApp.Sheets("Seleção Escolas").Cells(grupo + 7, "A") = "x"
        excelApp.Sheets("Seleção Escolas").Cells(4, "A") = data
        excelApp.Sheets("Seleção Escolas").Cells(5, "A") = hora
        excelApp.Sheets("Seleção Escolas").Cells(1, "C") = nomeArquivo
        excelApp.Run ("chamarMetodos")
        excelApp.DisplayAlerts = False
        excelApp.ActiveWorkbook.Close
        
        texto = saudacao & "<br><br>Segue lista de espera da unidade parceira solicitada.<br><br>"
        nomeArquivo = ListaArquivos("[caminho da pasta]\enviar")
        
        Call encaminharEmailParceira(objMail, email, texto, "[caminho da pasta]\enviar\" & nomeArquivo)
        
        Kill ("[caminho da pasta]\enviar\" & nomeArquivo)
        
        excelApp.Quit
        Set objMail = Nothing
        Set excelApp = Nothing
        nomeEscola = ""
        idEscola = 0
        email = ""
    Else
        nomeArquivo = ListaArquivos("[caminho da pasta]\Atual")
        data = Mid(nomeArquivo, 46, InStr(46, nomeArquivo, "_") - 46)
        hora = Mid(nomeArquivo, InStr(46, nomeArquivo, "_") + 1, InStr(1, nomeArquivo, ".") - InStr(46, nomeArquivo, "_"))
        hora = Left(hora, Len(hora) - 1)
        
        Set excelApp = New Excel.Application
        excelApp.DisplayAlerts = False
        excelApp.ScreenUpdating = False
        excelApp.Visible = True
        excelApp.Workbooks.Open ("[caminho da pasta]\Geração_ListaEspera_PARCEIRAS_2021_v2.6 - OUTLOOK.xlsm")
        excelApp.Wait (Now + TimeValue("0:00:01"))
        excelApp.Sheets("Seleção Escolas").Select
        DoEvents
        excelApp.Sheets("Seleção Escolas").Cells(grupo + 7, "A") = "x"
        excelApp.Sheets("Seleção Escolas").Cells(4, "A") = data
        excelApp.Sheets("Seleção Escolas").Cells(5, "A") = hora
        excelApp.Sheets("Seleção Escolas").Cells(1, "C") = nomeArquivo
        excelApp.Run ("chamarMetodos")
        excelApp.DisplayAlerts = False
        excelApp.ActiveWorkbook.Close
        
        texto = saudacao & "<br><br>Segue lista de espera da unidade parceira solicitada.<br><br>"
        nomeArquivo = ListaArquivos("[caminho da pasta]\enviar")
        
        Call encaminharEmailParceira(objMail, email, texto, "[caminho da pasta]\enviar\" & nomeArquivo)
        
        Kill ("[caminho da pasta]\enviar\" & nomeArquivo)
        
        excelApp.Quit
        Set objMail = Nothing
        Set excelApp = Nothing
        nomeEscola = ""
        idEscola = 0
        email = ""
    End If
End Sub

The rule setting is in the following image:

I really have no idea what might be causing this mistake.

Answer 1

Ricardo, blah, blah! I recommend that you always use a log to identify the error that is being generated, if unsolicited will not be informed, I will put below how you should do. 1st right after the start: Public Sub Sendersports(As Outlook Item.Mailitem) insert:

On Error Goto Err_Control

2º At the end of Sub or Functions, enter:

Err_Control:    
If Err.Number <> 0 Then
        MsgBox Err.Description
        Call LogErr("Insira_aqui_o_nome_que_quiser, identifica Sub or function", Err.Number, Err.Description)
    End If

Below the Function that writes in a txt file the errors where the code is executed, use it for Excel, not tested in Outlook, can be commented on so that it does not run, but at least the function Msgbox Err.Description, will inform error, and you can increment by displaying error number:

Msgbox "Description error:" & Err.Description & " Error number:" & Err.Number.

might help, just remove "Call Logerr" to not trigger the Log file.

Public Function LogErr(Modulo As String, ErrNumber As Long, ErrDescription As String)
On Error Resume Next
Dim strFile_Path As String
strFile_Path = Application.ActiveWorkbook.path & "\" & ActiveWorkbook.Name & "_" & "log_file.txt"
    Open strFile_Path For Append As #1
    Write #1, Now() & " | Módulo: " & Modulo & " | Err_Number: " & ErrNumber & " | Err_Description: " & ErrDescription & " | Máquina: " & Environ$("computername") & " | User: " & Application.UserName
    Close #1
End Function

To find out your "Application.ActiveWorkbook.path" locations use debug, in your case remove the continuation "Activeworkbook.Name" this very use for Excel, try to adapt to better identify what is causing your error, hope it helps. Try to test yourself by sending emails, do mass testing and then adapt to use as you wish.