Envio de Mala Direta por Email com VBA

Objetivo: Enviar mala direta por email a partir de uma lista de clientes, alterando o corpo da mensagem conforme cada cliente.

Fazendo uma pequena adaptação do post http://guiadoexcel.com.br/enviar-email-com-excel-sem-usar-o-outlook.

Neste artigo temos um pequeno exemplo de uma mensagem particular para cada cliente da lista sendo enviado diretamente pelo Excel com uso de VBA.

Atenção: Não esqueça de abrir o VBA e alterar os campos com o seu email, senha e configurações de porta smtp, etc. Se for Gmail, basta colocar seu nome, email e senha.

Este artigo também foi criado para auxiliar o leitor Luiz de São Paulo que estava com esta necessidade. Espero que ajude.

Código Fonte:

'Baseado no código disponibilizado em: http://www.a1vbcode.com/snippet-3691.asp
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") = "seuemail.rieper@gmail.com"
    '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 = "marcos.rieper@gmail.com"
        '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

Abraço

Marcos Rieper