Notifications
Clear all

VBA anexa e envia

3 Posts
1 Usuários
0 Reactions
1,668 Visualizações
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Excel enviar email para clientes diferentes com anexos diferente (cada cliente receberá um anexo diferente) Veja imagem anexo

Alguém poderia me ajudar???
Alguém já fez algo assim??
Tenho esse código como referencia falata adaptá-lo.

Sub lsEnviaEmail(ByVal lEmail As String, ByVal lMsg As String)
Dim iMsg, iConf, Flds

'Seta as variáveis, lembrando que o objeto Microsoft CDO deverá estar habilitado em Ferramentas->Referências->Microsoft CDO for Windows 2000 Library
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

'Configura o componente de envio de email
schema = " http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
'Configura o smtp
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
'Configura a porta de envio de email
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
'Configura o email do remetente
Flds.Item(schema & "sendusername") = "[email protected]"
'Configura a senha do email remetente
Flds.Item(schema & "sendpassword") = "suasenha"
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

With iMsg
'Email do destinatário
.To = lEmail
'Seu email
.From = "SeuNome "
'Título do email
.Subject = "Isto é um teste de Envio de email"
'Mensagem do e-mail, você pode enviar formatado em HTML
.HTMLBody = lMsg
'Seu nome ou apelido
.Sender = "Teste"
'Nome da sua organização
.Organization = "Empresa Teste"
'email de responder para
.ReplyTo = "[email protected]"
'Anexo a ser enviado na mensagem
'.AddAttachment ("c:fatura.txt")
'Passa a configuração para o objeto CDO
Set .Configuration = iConf
'Envia o email
SendEmailGmail = .Send
End With

'Limpa as variáveis
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub

Public Sub lsEnviarEmails()
Dim iTotalLinhas, i As Integer

iTotalLinhas = Cells(Rows.Count, 1).End(xlUp).Row + 1

i = 2
While i < iTotalLinhas
lsEnviaEmail Range("B" & i).Value, "Mensagem para o cliente " & Range("A" & i).Value
i = i + 1
Wend
End Sub

 
Postado : 20/07/2011 9:34 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 


Fiz algumas alterações, mas não consigo testar daqui...

Faça um teste com e-mails adequados e caso ocorra algum erro, reporte indicando qual a mensagem e, caso o resultado ainda não seja o esperado, indique o que ocorre.

Sub lsEnviaEmail(par_mail, par_anexo, par_mensagem)
Dim iMsg, iConf, Flds

'Seta as variáveis, lembrando que o objeto Microsoft CDO deverá estar habilitado em Ferramentas->Referências->Microsoft CDO for Windows 2000 Library
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

'Configura o componente de envio de email
schema = " http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
'Configura o smtp
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
'Configura a porta de envio de email
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
'Configura o email do remetente
Flds.Item(schema & "sendusername") = "[email protected]"
'Configura a senha do email remetente
Flds.Item(schema & "sendpassword") = "suasenha"
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

With iMsg
'Email do destinatário
.To = par_mail
'Seu email
.From = "SeuNome "
'Título do email
.Subject = "Isto é um teste de Envio de email"
'Mensagem do e-mail, você pode enviar formatado em HTML
.HTMLBody = par_mensagem
'Seu nome ou apelido
.Sender = "Teste"
'Nome da sua organização
.Organization = "Empresa Teste"
'email de responder para
.ReplyTo = "[email protected]"
'Anexo a ser enviado na mensagem
.AddAttachment (par_anexo)
'Passa a configuração para o objeto CDO
Set .Configuration = iConf
'Envia o email
SendEmailGmail = .Send
End With

'Limpa as variáveis
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub

Public Sub lsEnviarEmails()
Dim iTotalLinhas, i As Integer

iTotalLinhas = Cells(Rows.Count, 1).End(xlUp).Row + 1

i = 2
While i < iTotalLinhas
par_mail = Cells(i, 3)
par_anexo = Cells(i, 2)
par_mensagem = Cells(i, 4)
Call lsEnviaEmail(par_mail, par_anexo, par_mensagem)
i = i + 1
Wend
End Sub

 
Postado : 20/07/2011 11:35 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Primeiramente quero agradecer pelo atendimento.

Edson meu caro tá dando o seguinte erro de depuração:

o protoclo especificado é desconhecido

.AddAttachment (par_anexo) fica marcado em amarelo

Mas uma vez muito grato!

 
Postado : 20/07/2011 6:42 pm