Excel Enviando e-mail via vba

[Yskhadar]

Olá

Peço uma ajuda dos feras daqui...

Estou com uma macro que funciona quase perfeitamente, ao menos pro que eu preciso.

Ela faz o envio de e-mail pelo excel direto pelo Gmail.

Achei uma planilha e fiz adaptação para o que eu preciso, mas não estou conseguindo meu objetivo.

Ela copia o e-mail do destinatário, copia o anexo e faz o envio do e-mail.

Na hora do envio, apesar de atualizar a planilha, os anexos vão se acumulando.

O primeiro e-mail vai certo, o segundo recebe o anexo do primeiro mais o segundo, o terceiro recebe todos os anteriores e assim por diante.

Posto a macro aqui na esperança de conseguir uma ajuda.

Antecipadamente agradeço.

 

Sub EnviaEmail()

 

Application.EnableEvents = False

Dim iMsg, iConf, Flds
Dim N As Integer
Dim NEmails As Integer

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
Set ws = Worksheets

N = 2
flag = 0
NEmails = ws("Relação").Range("C1") + 2

schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = ws("ConfigEmail").Range("C4")
'Configura o smtp
Flds.Item(schema & "smtpserver") = ws("ConfigEmail").Range("C5")
'Configura a porta de envio de email
Flds.Item(schema & "smtpserverport") = ws("ConfigEmail").Range("C6")
Flds.Item(schema & "smtpauthenticate") = ws("ConfigEmail").Range("C7")
'Configura o email do remetente
Flds.Item(schema & "sendusername") = ws("Email").Range("C5")
'Configura a senha do email remetente
Flds.Item(schema & "sendpassword") = ws("Email").Range("C6")
Flds.Item(schema & "smtpusessl") = ws("ConfigEmail").Range("C8")
Flds.Update

Do While N < NEmails

    ws("Relação").Cells(N, 2).Copy
    ws("Email").Activate
    ws("Email").Range("C8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
    Application.CutCopyMode = False
    
    ws("Relação").Cells(N, 3).Copy
    ws("Email").Activate
    ws("Email").Range("B15").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
    Application.CutCopyMode = False

With iMsg

   'Seu nome ou apelido
   .From = ws("Email").Range("C3")
   'Seu e-mail
   .Sender = ws("Email").Range("C5")
   
   'Email do destinatário
   .To = ws("Email").Range("C8")
   'Cópia
   .CC = ws("Email").Range("C9")
   'Cópia Oculta
   .BCC = ws("Email").Range("C10")
   'Anexo
    .AddAttachment ws("Email").Range("B15")
   
   'Título do email
   .Subject = ws("Email").Range("C12")
   'Nome da sua organização
   '.Organization = ""
   'e-mail de responder para
   '.ReplyTo = Worksheets("Email").Range("C3")
   
   'Mensagem do e-mail, você pode enviar formatado em HTML
   .HTMLBody = ws("Email").Range("E4") & " " & Sheets("Relação").Cells(N, 1) & "<br>" & "<br>" _
    & ws("Email").Range("E5") & "<br>" & "<br>" _
    & ws("Email").Range("E6") & "<br>" & "<br>" _
    & ws("Email").Range("E7") & "<br>" _
    & ws("Email").Range("E8") & "<br>" _
    & ws("Email").Range("E9") & "<br>" & "<br>" _
    & ws("Email").Range("E10") & "<br>" & "<br>" _
    & ws("Email").Range("E11") & "<br>" _
    & ws("Email").Range("E12") & "<br>" _
    & ws("Email").Range("E13")
   
    flag = 1
    Set .Configuration = iConf
    
    'Envia o email
    .Send
      
End With

N = N + 1
ws("Email").Range("C8,B15").ClearContents

Loop

ws("Email").Range("C8,B15").ClearContents

Application.EnableEvents = True

MsgBox N - 2 & " e-mails foram enviados com sucesso", vbOKOnly

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing

 

End Sub

[Basole]

@Yskhadar no seu codigo o anexo .AddAttachment ws("Email").Range("B15") a impressão é que a celular B15 não esta sendo atualizada, alterando o endereço do anexo.

Para dar um parecer melhor seria bom se disponiblizasse a planilha, ou um modelo com alguns dados ficticios, para poder entendermos melhor o funcionamento e formatação dela.

 

[Yskhadar]

Oi Basole

 

Segue planilha anexo

Teste.zip

[Basole]

@Yskhadar para cada envio de e-mail, cria um novo objeto de email CDO.

 

Veja as alterações:

 

Sub EnviaEmail()

Application.EnableEvents = False

Dim iMsg, iConf, Flds, ws
Dim N       As Integer
Dim NEmails As Integer

Set ws = Worksheets

N = 2
flag = 0
NEmails = ws("Relação").Range("C1") + 1

Do While N <= NEmails

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
Set ws = Worksheets

schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = ws("ConfigEmail").Range("C4")
'Configura o smtp
Flds.Item(schema & "smtpserver") = ws("ConfigEmail").Range("C5")
'Configura a porta de envio de email
Flds.Item(schema & "smtpserverport") = ws("ConfigEmail").Range("C6")
Flds.Item(schema & "smtpauthenticate") = ws("ConfigEmail").Range("C7")
'Configura o email do remetente
Flds.Item(schema & "sendusername") = ws("Email").Range("C5")
'Configura a senha do email remetente
Flds.Item(schema & "sendpassword") = ws("Email").Range("C6")
Flds.Item(schema & "smtpusessl") = ws("ConfigEmail").Range("C8")
Flds.Update

    ws("Relação").Cells(N, 2).Copy
    ws("Email").Activate
    ws("Email").Range("C8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
    Application.CutCopyMode = False
    
    ws("Relação").Cells(N, 3).Copy
    ws("Email").Activate
    ws("Email").Range("B15").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
    Application.CutCopyMode = False

With iMsg

   'Seu nome ou apelido
   .From = ws("Email").Range("C3")
   'Seu e-mail
   .Sender = ws("Email").Range("C5")
   
   'Email do destinatário
   .To = ws("Email").Range("C8")
   'Cópia
   .CC = ws("Email").Range("C9")
   'Cópia Oculta
   .BCC = ws("Email").Range("C10")
   'Anexo
   .AddAttachment ws("Email").Range("B15")
   
   'Título do email
   .Subject = ws("Email").Range("C12")
   'Nome da sua organização
   '.Organization = "Escola de Pais do Brasil"
   'e-mail de responder para
   '.ReplyTo = Worksheets("Email").Range("C3")
   
   'Mensagem do e-mail, você pode enviar formatado em HTML
   .HTMLBody = ws("Email").Range("E4") & " " & Sheets("Relação").Cells(N, 1) & "<br>" & "<br>" _
    & ws("Email").Range("E5") & "<br>" & "<br>" _
    & ws("Email").Range("E6") & "<br>" & "<br>" _
    & ws("Email").Range("E7") & "<br>" _
    & ws("Email").Range("E8") & "<br>" _
    & ws("Email").Range("E9") & "<br>" & "<br>" _
    & ws("Email").Range("E10") & "<br>" & "<br>" _
    & ws("Email").Range("E11") & "<br>" _
    & ws("Email").Range("E12") & "<br>" _
    & ws("Email").Range("E13")
   
    flag = 1
    Set .Configuration = iConf
    
    'Envia o email
    .Send
   
End With

ws("Email").Range("C8,B15").ClearContents

Application.EnableEvents = True

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing

N = N + 1
Loop

MsgBox N - 2 & " e-mails foram enviados com sucesso", vbOKOnly, "EPB"

End Sub

 

[Yskhadar]

@Basole  Perfeito

Quem sabe, sabe.

Muitíssimo obrigado Basole.

 

 

[Yskhadar]

Tardes...

 

Seguindo a linha da consulta em histórico, mudei um pouco a planilha.

Ao invés de uma linha para cada parágrafo no e-mail, eu coloquei tudo na mesma célula e formatei.

Consigo encaminhar, mas não consigo que vá com assinatura do e-mail que é uma imagem.

Se eu uso o &.HTMLBody ele junta tudo, não consigo quebrar linhas...

Já revirei por ai e não achei.

Alguém consegue me ajudar?