[Resolvido]Emvio de email em massa sem outlook

Caros Amigos,

Adaptei o código (retirado aqui do forum) abaixo para enviar emails em massa. Em outras palavras, filtro os aniversariantes de determinado intervalo de datas e desejo enviar mensagens para todos. O que ocorre é que só envia para o primeiro da relação. Onde está o erro desta rotina? Não consigo entender. Juntei um código que envia em massa com outlook com outro que envia sem outlook para um único email. Ajudem-me.

Grande abraço

Sub EnviarEmailCDOSolicitante()
Dim oMensagem As Object
Dim oConfiguração As Object
Dim sCorpo As String
Dim vFields As Variant
Dim sDestinatário As String
Dim sCc As String
Dim sCco As String
Dim sMsgTempo As String
Dim strLocal As String

' ---------------------------------------------

Set Rst = CurrentDb.OpenRecordset("TbEmail AUX")

Do Until Rst.EOF

em1 = Rst.Fields("Email")
''em2 = rst.Fields("E_mail_2")

If Not IsNull(em1) Then
   strDestinatarios = strDestinatarios & Rst("EMail") & ";"
End If

''If Not IsNull(em2) Then
 '  'strDestinatarios = strDestinatarios & rst("E_Mail_2") & ";"
''End If

Rst.MoveNext

Loop

''strDestinatarios = Left(strDestinatarios, Len(strDestinatarios) - 1)

'----------------------------------------------------------------




' ---------------------------------------------




sDestinatário = strDestinatarios
'sDestinatário = Email
'sCc = ""
'sCco = ""
'If Not IsNull([arquivo]) Then
'strLocal = arquivo
'Else
'End If

'If MsgBox("Enviar e-mail para o destinatário " & Destinatário & vbNewLine & _
'"através do e-mail " & sDestinatário, vbYesNo + vbQuestion, "  InfoBasic Smart System") = vbYes Then

'If IsNull(sDestinatário) Then
'MsgBox "Não há endereço de e-mail" & Chr(10) & _
'"cadastrado para o destinatário " & Destinatário & "!", vbOKOnly + vbInformation
'Exit Sub
'End If

'If IsNull(Email) Then
'MsgBox "O e-mail não pode ser enviado!" & Chr(10) & _
'"Verifique a existência do endereço.", vbOKOnly + vbCritical
'Exit Sub
'End If

'If IsNull(Assunto) Then
'MsgBox "O e-mail não pode ser enviado!" & Chr(10) & _
'"Informe o Assunto deste encaminhamento.", vbOKOnly + vbCritical
'Me.Assunto.SetFocus
'DoCmd.CancelEvent
'Exit Sub
'End If

Assunto = "Parabéns pelo seu aniversário..."

'If Me.Texto = "" Then
'MsgBox "O e-mail não pode ser enviado!" & Chr(10) & _
'"O campo Mensagem encontra-se em branco.", vbOKOnly + vbCritical
'Me.Texto.SetFocus
'DoCmd.CancelEvent
'Exit Sub
Texto = "Confesso que hoje não consigo expressar toda minha alegria, simplesmente pelo fato de saber que nesta data tão maravilhosa você está muito mais feliz. Que Deus ilumine todos os dias da sua vida, abençoando seu aniversário!"
Texto1 = "São os mais sinceros desejos do seu amigo MARCOS MENEZES. Grande abraço"


'Else

'DoCmd.OpenForm "frmProgresso"
'Forms!frmProgresso!lblInfo.Caption = "Enviando dados..." & vbCrLf & "Esse processo pode levar vários minutos dependendo o tamanho dos arquivos enviados e da velocidade da Internet." & vbCrLf & vbCrLf & "Por favor, aguarde..."


Set oMensagem = CreateObject("CDO.Message")
Set oConfiguração = CreateObject("CDO.Configuration")

oConfiguração.Load -1 'Padrões CDO
Set vFields = oConfiguração.Fields
With vFields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" 'pode ser usado outro smtpserver
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 ' existem outros smtpserverport. verifique na internet
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
'.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "petrus.empresarial@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "marcosmenezesmulti@gmail.com"
'.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Petrusge2000"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Daniel2015"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60

.Update
End With

If Format(Now, "hh:mm:ss") >= "00:00:01" And Format(Now, "hh:mm:ss") < "12:00:00" Then
sMsgTempo = "bom dia"
ElseIf Format(Now, "hh:mm:ss") >= "12:01:00" And Format(Now, "hh:mm:ss") < "18:00:00" Then
sMsgTempo = "boa tarde"
ElseIf Format(Now, "hh:mm:ss") >= "18:01:00" And Now = Format(Now, "hh:mm:ss") < "23:59:59" Then
sMsgTempo = "boa noite"
End If


sCorpo = "Prezado(a) Senhor(a), " & [sMsgTempo] & vbNewLine & vbNewLine & Texto & vbNewLine & vbNewLine & Texto1
'& vbNewLine & _
'vbNewLine & _
'vbNewLine & _
'DLookup("[RSocial]", "tblEmpresa") & vbNewLine & _
'"Endereço: " & [txtEnder] & vbNewLine & _
'"Fale conosco: Tel/Fax " & [txtComunicação] & vbNewLine

With oMensagem
Set .Configuration = oConfiguração
.To = Me.Email 'mude aqui para alterar o destinatário
'If IsNull([CC]) Then
'.CC = ""
'Else
'.CC = Me.CC 'com cópia
'End If
'If IsNull([Cco]) Then
'.BCC = ""
'Else
'.BCC = Me.Cco 'com cópia oculta
'End If
.From = "marcosmenezesmulti@gmail.com" 'mude para o seu e-mail
.Subject = "" & Assunto ' mude para o assunto que desejar
.TextBody = sCorpo
'If Not IsNull([arquivo]) Then
'.AddAttachment strLocal
'Else: End If
.Send
End With
'DoCmd.Close acForm, "frmProgresso"
MsgBox "E-mail enviado com sucesso.   ", vbInformation, "  Parabéns aniversariantes"
'End If
Exit Sub

End Sub

Caros amigos,

Sei que não tiveram o tempo suficiente para analisar o código, porém consegui descobrir. Era apenas troca de noves de variáveis. Tudo OK. Contudo, muito obrigado a todos.

Grande abraço

Olá Kinhosinfo, bom dia.

Amigão, fui eu quem disponibilizou o programa do qual você diz ter tirado o código da Petrus Empresarial.
Gostaria de, se possível, que você disponibilizasse o seu aplicativo para que possamos estudar o seu código.
Obs: meu Access ainda é o velho e bom 2003.

Abraços, WSenna

Grande WSenna,

Muito grato pelo seu interesse com este meu problema. Sua intenção com seu código era enviar emails só para um destinatário, como demonstra no formulário, ou pode adaptar para envios em massa? Fiz diversas alterações, conforme código acima, porém só enviava para um destinatário. Depois de batalhar muito notei que havia trocado os nomes de variáveis. Consertei e acho que resolveu. Veja linhas abaixo:

.To = Me.Email 'mude aqui para alterar o destinatário ----------- Para meu código alterado a variável está errada.

.To = sDestinatário ------------- Esta seria a minha variável correta.

Seria isso mesmo para envios em massa?

Muito grato

Grande abraço.