Skip to main content
Ajuste no exemplo e correção do código final.
Fonte Link
AleGR
  • 150
  • 5
Dim CaminhoArquivo As String

CaminhoArquivo = (ThisWorkbook.Path & "\Certificado_" & Cells(lin, 2).Value & ""\nome_arquivo.pptx")
    
If Dir(CaminhoArquivo) = "" Then ' O arquivo não existe
    MsgBox "O arquivo " & CaminhoArquivo & " não existe."
    Exit Sub
End If
Sub Envia_Emails(EnviarPara As String, Mensagem As String, CaminhoArquivo As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim CaminhoArquivo As String
    ' Trecho de código adicionado
    'Set <<----------INICIO----------OutlookApp = CreateObject("Outlook.Application")
    DimSet CaminhoArquivoOutlookMail As= StringOutlookApp.CreateItem(0)
    
    For lin = 1 To 2
        CaminhoArquivo = (ThisWorkbook.Path & "\Certificado_testex"\Certificado_" & Cells(lin, 2).Value & ".pptx")
    
        If Dir(CaminhoArquivo) = "" Then
            MsgBox "O arquivo "'" & CaminhoArquivo & ""' não existe."
   e o e-mail não será Exitenviado.", SubvbCritical
    End If
    ' -------------FIM---------->>Else
    
     Set OutlookApp = CreateObject("Outlook.Application")
    SetWith OutlookMail = OutlookApp.CreateItem(0)
    
     For lin = 1 To 2
   .to = EnviarPara
   With OutlookMail
            .toCC = EnviarPara""
            .CC = ""
            .BCC = ""
                .Subject = "Teste"
                .Body = Mensagem & Chr(10) & Chr(10) & "Atenciosamente"
                .Attachments.Add CaminhoArquivo 
 ' <<--- EDITADO
             .Send
            End With
            
            MsgBox "Email enviado com o arquivo '" & CaminhoArquivo & "' como anexo.", vbInformation
        End If
    Next
    
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
Dim CaminhoArquivo As String

CaminhoArquivo = (ThisWorkbook.Path & "\Certificado_" & Cells(lin, 2).Value & ".pptx")
    
If Dir(CaminhoArquivo) = "" Then ' O arquivo não existe
    MsgBox "O arquivo " & CaminhoArquivo & " não existe."
    Exit Sub
End If
Sub Envia_Emails(EnviarPara As String, Mensagem As String, CaminhoArquivo As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    
    ' Trecho de código adicionado
    ' <<----------INICIO----------
    Dim CaminhoArquivo As String
    
    CaminhoArquivo = ThisWorkbook.Path & "\Certificado_testex.pptx"
    
    If Dir(CaminhoArquivo) = "" Then
        MsgBox "O arquivo " & CaminhoArquivo & " não existe."
        Exit Sub
    End If
    ' -------------FIM---------->>
    
     Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    
     For lin = 1 To 2
        With OutlookMail
            .to = EnviarPara
            .CC = ""
            .BCC = ""
            .Subject = "Teste"
            .Body = Mensagem & Chr(10) & Chr(10) & "Atenciosamente"
            .Attachments.Add CaminhoArquivo ' <<--- EDITADO
            .Send
        End With
    Next
    
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
Dim CaminhoArquivo As String

CaminhoArquivo = ThisWorkbook.Path & "\nome_arquivo.pptx"
    
If Dir(CaminhoArquivo) = "" Then
    MsgBox "O arquivo " & CaminhoArquivo & " não existe."
    Exit Sub
End If
Sub Envia_Emails(EnviarPara As String, Mensagem As String, CaminhoArquivo As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim CaminhoArquivo As String
        
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    For lin = 1 To 2
        CaminhoArquivo = (ThisWorkbook.Path & "\Certificado_" & Cells(lin, 2).Value & ".pptx")
    
        If Dir(CaminhoArquivo) = "" Then
            MsgBox "O arquivo '" & CaminhoArquivo & "' não existe e o e-mail não será enviado.", vbCritical
        Else
             With OutlookMail
                .to = EnviarPara
                .CC = ""
                .BCC = ""
                .Subject = "Teste"
                .Body = Mensagem & Chr(10) & Chr(10) & "Atenciosamente"
                .Attachments.Add CaminhoArquivo 
                .Send
            End With
            
            MsgBox "Email enviado com o arquivo '" & CaminhoArquivo & "' como anexo.", vbInformation
        End If
    Next
    
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
Fonte Link
AleGR
  • 150
  • 5

Eu testei seu código e ele funciona. O que pode estar acontecendo é que está tentando anexar um arquivo que não existe.

O que você pode fazer é adicionar um if para verificar se o arquivo existe antes de tentar montar o e-mail e exibir uma mensagem para o usuário caso o arquivo não seja encontrado.

Essa verificação pode ser feita usando a função Dir, como, por exemplo:

Dim CaminhoArquivo As String

CaminhoArquivo = (ThisWorkbook.Path & "\Certificado_" & Cells(lin, 2).Value & ".pptx")
    
If Dir(CaminhoArquivo) = "" Then ' O arquivo não existe
    MsgBox "O arquivo " & CaminhoArquivo & " não existe."
    Exit Sub
End If
.Attachments.Add CaminhoArquivo

Código atualizado:

Sub Envia_Emails(EnviarPara As String, Mensagem As String, CaminhoArquivo As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    
    ' Trecho de código adicionado
    ' <<----------INICIO----------
    Dim CaminhoArquivo As String
    
    CaminhoArquivo = ThisWorkbook.Path & "\Certificado_testex.pptx"
    
    If Dir(CaminhoArquivo) = "" Then
        MsgBox "O arquivo " & CaminhoArquivo & " não existe."
        Exit Sub
    End If
    ' -------------FIM---------->>
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    For lin = 1 To 2
        With OutlookMail
            .to = EnviarPara
            .CC = ""
            .BCC = ""
            .Subject = "Teste"
            .Body = Mensagem & Chr(10) & Chr(10) & "Atenciosamente"
            .Attachments.Add CaminhoArquivo ' <<--- EDITADO
            .Send
        End With
    Next
    
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub