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
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