VBA (Excel/Outlook): Anexar arquivo PDF ao e-mail

2024 - VBA & Macros

Post Recente por LaerteB 5 anos atrás

3 Posts

2 Usuários

0 Reactions

1,154 Visualizações

RSS

Santos

(@santos)

Posts: 1

New Member

Topic starter

Olá,
Obrigado pelo espaço.

Preciso de uma ajuda....

Utilizarei as células da coluna "J" para colocar o local de arquivos específicos. Ex:
"J1" C:/a.pdf
"J2" C:/b.pdf, etc.
Seria um arquivo para cada linha, sem limites, usarei a coluna inteira se for necessário.
Nas células anteriores já estão definidos o "contato, e-mail e texto".

A1 B1 C1 D1 E1 F1 G1 H1 I1 J1
HOJE DATA Nº DATA F-UP DIAS1 RETORNO CONTATO E-MAIL MSG ARQUIVO

Já tentei anexar com o comando "Attachment.add", mas não consegui e mesmo assim pelo que entendi, este comando é para envio de um arquivo fixo para todos os e-mails, o que não me ajudaria, pois preciso enviar arquivos diferentes para diversos e-mails.

Abaixo o código que utilizo para enviar os e-mails.

Sub MandaEmail()
    
    Dim EnviarPara As String
    Dim Mensagem As String
     For F = 1 To Cells(Rows.Count, 1).End(3).Row
        EnviarPara = ThisWorkbook.Sheets(1).Cells(F, 8)
        If EnviarPara <> "" And Cells(F, "F") = "FOLLOWUP" Then
            Mensagem = ThisWorkbook.Sheets(1).Cells(F, 9)
            Envia_Emails EnviarPara, Mensagem
        End If
    Next F
End Sub

Sub Envia_Emails(EnviarPara As String, Mensagem As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = EnviarPara
        .CC = ""
        .BCC = ""
        .Subject = "Proposta enviada"
        .Body = Mensagem
        .Display ' para envia o email diretamente defina o código  .Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Agradeço desde já.

Não enviei a planilha, pois não encontrei onde anexar.

Postado : 20/10/2019 7:47 pm

LaerteB

(@laerteb)

Posts: 67

Trusted Member

Boa noite, Santos

Por enquanto ainda não está liberado o anexo (o Fórum está passando por manutenção), então tu podes colocar o seu
arquivo exemplo nos sites como SendSpace, DropBox e outros e depois informar aqui o link para baixá-los ...

Uma dica muito importante, é você sempre anexar uma planilha de exemplo com dados (fictícios) e que não seja o
projeto inteiro (com o trecho que está com dificuldades); explicando com as informações necessárias
para alcançar o seu objetivo (se necessário incluir imagens elucidativas), desta forma podemos
ajudá-lo com maior rapidez e eficácia (a maioria nem olharia este Tópico sem um arquivo exemplo,
pois existe muitas "variáveis" que podem impossibilitar o sucesso parcial ou total da solução
proposta, se não tiver um arquivo exemplo que for disponibilizado) ..

Como não tem um exemplo, vamos no "chutômetro" ... abaixo os códigos que substituirão o seu:

Sub MandaEmail()

Dim EnviarPara As String
Dim Mensagem As String
Dim Arquivo As String

For F = 1 To Cells(Rows.Count, 1).End(3).Row

EnviarPara = ThisWorkbook.Sheets(1).Cells(F, 8)

If EnviarPara <> "" And Cells(F, "F") = "FOLLOWUP" Then
Mensagem = ThisWorkbook.Sheets(1).Cells(F, 9)
Arquivo = ThisWorkbook.Sheets(1).Cells(F, 10)

Envia_Emails EnviarPara, Mensagem, Arquivo

End If

Next F

End Sub

Sub Envia_Emails(EnviarPara As String, Mensagem As String, Arquivo As String)

Dim OutlookApp As Object
Dim OutlookMail As Object

Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

With OutlookMail
.To = EnviarPara
.CC = ""
.BCC = ""
.Subject = "Proposta enviada"
.Body = Mensagem
.Attachments.Add Arquivo
.Display ' para envia o email diretamente defina o código .Send

End With

Set OutlookMail = Nothing
Set OutlookApp = Nothing

End Sub

Por gentileza verificar se isto resolve a sua questão ..