Excel Enviar E-mail automático com anexo (PDF)

[ppeterk]

Amigos, bom dia! Gostaria da ajuda de vocês, por gentileza:
 

Tenho uma planilha com vários nomes de pessoas, os e-mails dessas pessoas e uma mensagem padrão. Do lado de fora, na pasta eu vou criar alguns PDFs cujo título será o nome das pessoas da planilha. Gostaria de uma macro que enviasse todos os e-mails, com a mensagem padrão e o PDF dessa pessoa como anexo.

 

Estou anexando a planilha e 2 PDFs de exemplo.

Enviar e-mails.xlsx LUIS HENRIQUE.pdf MATEUS EDUARDO.pdf

[ppeterk]

Amigos, bom dia!

 

Consegui montar esse código. Ele faz toda a etapa de enviar os emails com os PDFs em anexo. Inclusive, acrescenta a assinatura do Outlook. No entanto, algumas vezes, ele não chega para o destinatário, como se tivesse "agarrado" na fila de envio Alguém consegue me dar alguma solução?:
 

Option Explicit

Sub EnviarEmailsComPDF()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim UltimaLinha As Long
    Dim i As Long
    Dim PastaPDF As String
    Dim CaminhoPDF As String
    Dim NomeArquivo As String
    Dim CorpoPadrao As String
     
    '=== Solicita ao usuário a pasta onde estão os PDFs ===
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Selecione a pasta onde estão os PDFs"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "Nenhuma pasta selecionada. Operação cancelada.", vbExclamation
            Exit Sub
        End If
        PastaPDF = .SelectedItems(1)
        If Right(PastaPDF, 1) <> "\" Then PastaPDF = PastaPDF & "\"
    End With
    
    Set ws = ThisWorkbook.Sheets(1) 'Ajuste se necessário
    UltimaLinha = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    On Error GoTo ErroHandler
    Set OutlookApp = CreateObject("Outlook.Application")
    
    For i = 2 To UltimaLinha
        NomeArquivo = Trim(ws.Cells(i, "A").Value) & ".pdf"
        CaminhoPDF = PastaPDF & NomeArquivo
        
            '=== Texto fixo do e-mail (HTML) ===
    CorpoPadrao = "<p>Dr(a) " & Trim(ws.Cells(i, "A").Value) & ", bom dia" & _
                  "<p>Esperamos que esta mensagem o(a) encontre bem.</p>" & _

        
        If Dir(CaminhoPDF) <> "" Then
            Set OutlookMail = OutlookApp.CreateItem(0)
            With OutlookMail
                .Display   'Carrega a assinatura padrão
                'CorpoPadrao + Assinatura existente
                .HTMLBody = CorpoPadrao & .HTMLBody
                .To = ws.Cells(i, "B").Value
                .Subject = ws.Cells(i, "D").Value
                .Attachments.Add CaminhoPDF
                .Send    'Posso usar .Display para revisar antes de enviar ou Send
            End With
        Else
            MsgBox "Arquivo não encontrado: " & CaminhoPDF, vbExclamation, "Aviso"
        End If
    Next i
    
    MsgBox "E-mails enviados com sucesso!", vbInformation
    
Saida:
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Exit Sub

ErroHandler:
    MsgBox "Ocorreu um erro: " & Err.Description, vbCritical
End Sub