MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

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


    Enviar Email com CDO

    Assis
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3836
    Registrado : 06/11/2009

    Enviar Email com CDO Empty Enviar Email com CDO

    Mensagem  Assis em 11/5/2019, 10:57

    Bo dia Amigos

    Uso o código abaixo para enviar emails com CDO.

    Mas se o mail não for enviado ele é gravado numa tabela de mails enviados.


    Como só gravar o mail na tabela depois de ser enviado

    Obrigado



    Código:
    Dim BancoDeDados As dao.Database
    Dim TabLan?amentos As Recordset
    Dim Confirma


    Confirma = MsgBox("Confirma o Envio do Mail Para ?" & vbCrLf & Me.Texto38 & "", vbYesNo, "Gestão de @Mails")
    If Confirma = vbYes Then
    DoCmd.SetWarnings False
    DoCmd.RunCommand acCmdSpelling
    DoCmd.SetWarnings True
       'Inserindo o mail
       Set BancoDeDados = CurrentDb
       Set TabLan?amentos = BancoDeDados.OpenRecordset("Enviados")
       
           With TabLan?amentos
               .AddNew
               !TData = Date
               !Para = Me.txtPara
               !Nome = Me.txtDeMail
               !Assunto = Me.txtAssunto
               !Anexo = Me.txtAnexo
               !Anexo1 = Me.txtAnexo1
               !Anexo2 = Me.txtAnexo2
               !Mensagem = Me.txtMensagem
               !HoraEnvio = Time
               !Servidor = DLookup("Servidor", "DadosProprietario")
               .Update
           End With
     

    Call EnviarEmail

    Final:


    Else
    MsgBox "Cancelar Gravação do Mail ?", vbCritical, "@Mail não será Enviado"
     
         Call btnLimpar_Click

       Me.txtPara.SetFocus
     
    End If


    End Sub

    -------------------------------------------------------------------------------------------------------------------------------------
    Sub EnviarEmail()
       
       Set emailobj = CreateObject("CDO.Message")
       
       emailobj.From = Me.Email
       emailobj.To = Me.txtPara
       emailobj.Subject = Me.txtAssunto
       emailobj.TextBody = Me.txtMensagem
       
       Set emailConfig = emailobj.Configuration
           
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = DLookup("smtp", "DadosProprietario")
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = DLookup("porta", "DadosProprietario")
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = DLookup("email", "DadosProprietario")
       emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = DLookup("pass", "DadosProprietario")
       emailConfig.Fields.Update
       

    If Not IsNull(Me.txtAnexo) Then
    emailobj.AddAttachment (Me.txtAnexo)
    End If
    If Not IsNull(Me.txtAnexo1) Then
    emailobj.AddAttachment (Me.txtAnexo1)
    End If
    If Not IsNull(Me.txtAnexo2) Then
    emailobj.AddAttachment (Me.txtAnexo2)
    End If


    DoCmd.OpenForm "frmProgresso"

     emailobj.Send
     
       If err.Number = 0 Then MsgBox "@Mail Enviado com Sucesso", vbExclamation, "Gest?o de @Mails"

       DoCmd.Close acForm, "frmProgresso"

       DoCmd.Close acForm, "email"
       
       Set emailobj = Nothing
       Set emailConfig = Nothing



    End Sub


    .................................................................................
    *** Só sei que nada sei ***
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5973
    Registrado : 15/03/2013

    Enviar Email com CDO Empty Re: Enviar Email com CDO

    Mensagem  ahteixeira em 11/5/2019, 11:44

    Bom dia Assis,

    A usar acentuação em nome de variáveis, nem queria acreditar.
    O que fiz foi alterar a parte que "grava" para depois do IF que verifica se deu erro no envio e mostra a caixa de mensagem.
    A parte que "grava" abria o "Recordset" mas não fechava no fim,  mais atenção nesses códigos amigo.

    Veja se é isto:
    Código:
    Option Compare Database

    Dim BancoDeDados As dao.Database
    Dim TabLancamentos As Recordset
    Dim Confirma

    Confirma = MsgBox("Confirma o Envio do Mail Para ?" & vbCrLf & Me.Texto38 & "", vbYesNo, "Gestão de @Mails")

        If Confirma = vbYes Then
            DoCmd.SetWarnings False
            DoCmd.RunCommand acCmdSpelling
            DoCmd.SetWarnings True
           'Inserindo o mail
           '---Codigo retirado daqui ----
        Call EnviarEmail
    Final:
        Else
            MsgBox "Cancelar Gravação do Mail ?", vbCritical, "@Mail não será Enviado"
            Call btnLimpar_Click
            Me.txtPara.SetFocus
        End If
    End Sub

    Sub EnviarEmail()
      
        Set emailobj = CreateObject("CDO.Message")
        
        emailobj.From = Me.Email
        emailobj.To = Me.txtPara
        emailobj.Subject = Me.txtAssunto
        emailobj.TextBody = Me.txtMensagem
        
        Set emailConfig = emailobj.Configuration
            
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = DLookup("smtp", "DadosProprietario")
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = DLookup("porta", "DadosProprietario")
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = DLookup("email", "DadosProprietario")
        emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = DLookup("pass", "DadosProprietario")
        emailConfig.Fields.Update
      

        If Not IsNull(Me.txtAnexo) Then emailobj.AddAttachment (Me.txtAnexo)
        If Not IsNull(Me.txtAnexo1) Then emailobj.AddAttachment (Me.txtAnexo1)
        If Not IsNull(Me.txtAnexo2) Then emailobj.AddAttachment (Me.txtAnexo2)
        
        DoCmd.OpenForm "frmProgresso"
        
        emailobj.Send
        
        '--- If ajustado e colocado o codigo se seguir
        If err.Number = 0 Then
                Set BancoDeDados = CurrentDb
                Set TabLancamentos = BancoDeDados.OpenRecordset("Enviados")
          
               With TabLancamentos
                   .AddNew
                   !TData = Date
                   !Para = Me.txtPara
                   !Nome = Me.txtDeMail
                   !Assunto = Me.txtAssunto
                   !Anexo = Me.txtAnexo
                   !Anexo1 = Me.txtAnexo1
                   !Anexo2 = Me.txtAnexo2
                   !Mensagem = Me.txtMensagem
                   !HoraEnvio = Time
                   !Servidor = DLookup("Servidor", "DadosProprietario")
                   .Update
               End With
              
               'adicionado codigo abaixo pois faltava fechar o recordset e base dados
                TabLancamentos.Close
                Set TabLancamentos = Nothing
                Set BancoDeDados = Nothing
                '--------
                
            MsgBox "@Mail Enviado com Sucesso", vbExclamation, "Gest?o de @Mails"
        End If

        DoCmd.Close acForm, "frmProgresso"
        
        DoCmd.Close acForm, "email"
        
        Set emailobj = Nothing
        Set emailConfig = Nothing
    End Sub

    Abraço
    Assis
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3836
    Registrado : 06/11/2009

    Enviar Email com CDO Empty Re: Enviar Email com CDO

    Mensagem  Assis em 11/5/2019, 13:33

    Teixeira

    Testei alterando o email do destinatário (coloquei  anibal.assis@sapo.ptt ),   e deu erro de envio mas gravou igual na tabela.


    .................................................................................
    *** Só sei que nada sei ***
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5973
    Registrado : 15/03/2013

    Enviar Email com CDO Empty Re: Enviar Email com CDO

    Mensagem  ahteixeira em 11/5/2019, 15:51

    Olá Assis,

    Foi a "olho" que fiz alteração.
    Se registou, então também mostrou a mensgem a dizer que foi enviado.
    Apenas ajustei ao codigo apresentado.

    Verifique se tem tratamento de erro a funcionar.
    O Assis usa muito o on error resume next e se for o caso não vai funcionar.
    Estou no telemóvel, mas a única forma de só gravar quando enviar, precisa de ter um identificador se a mensagem foi enviada sem erro.

    Tente pesquisar.

    Abraço
    Assis
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3836
    Registrado : 06/11/2009

    Enviar Email com CDO Empty Re: Enviar Email com CDO

    Mensagem  Assis em 11/5/2019, 16:22

    Teixeira

    Sim mesmo assim informa que o mail foi enviado

    Retirei o On Error Resume Next e é igual

    Obrigado


    .................................................................................
    *** Só sei que nada sei ***
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5973
    Registrado : 15/03/2013

    Enviar Email com CDO Empty Re: Enviar Email com CDO

    Mensagem  ahteixeira em 11/5/2019, 16:51

    Olá Assis,

    Estou sem PC mas estive a pesquisar.
    Repare, uma coisa é o código dar erro no envio (que pelos vistos não é o caso)
    Outra coisa é não dar erro ao enviar, mas depois chegou ao destino e não existe o email e o servidor de e-mail dá erro de resposta a quem enviou.

    Vou meditar no assunto e aguardamos se algum colega tem alguma sugestão.

    Não creio que vá resolver, mas teste com a primeira opção de tratamento de erros
    http://www.maximoaccess.com/t30190-opcao-error-trapping-interceptacao-de-erro

    Abraço
    Assis
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3836
    Registrado : 06/11/2009

    Enviar Email com CDO Empty Re: Enviar Email com CDO

    Mensagem  Assis em 11/5/2019, 17:42

    Igual


    .................................................................................
    *** Só sei que nada sei ***

    Conteúdo patrocinado

    Enviar Email com CDO Empty Re: Enviar Email com CDO

    Mensagem  Conteúdo patrocinado


      Data/hora atual: 26/5/2019, 15:07