MaximoAccess

Caro Usuário, não tire as suas duvidas nas Salas de Repositório, abra sempre um novo tópico relacionado, nas salas destinadas para o efeito, como Sala de Tabelas, Consultas, Formulários, Relatórios, Macros, Módulos e VBA.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    [Resolvido]Emvio de email em massa sem outlook

    Compartilhe

    kinhosinfo
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 260
    Registrado : 23/03/2010

    [Resolvido]Emvio de email em massa sem outlook

    Mensagem  kinhosinfo em Ter 12 Maio 2015, 12:50

    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

    kinhosinfo
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 260
    Registrado : 23/03/2010

    Re: [Resolvido]Emvio de email em massa sem outlook

    Mensagem  kinhosinfo em Ter 12 Maio 2015, 14:35

    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

    wsenna
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 470
    Registrado : 22/12/2009

    Re: [Resolvido]Emvio de email em massa sem outlook

    Mensagem  wsenna em Qua 20 Maio 2015, 07:03

    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

    kinhosinfo
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 260
    Registrado : 23/03/2010

    Re: [Resolvido]Emvio de email em massa sem outlook

    Mensagem  kinhosinfo em Qui 21 Maio 2015, 01:27

    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.

      Data/hora atual: Qui 08 Dez 2016, 00:07