Enviar Email com CDO

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

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

Teixeira

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

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

Teixeira

Sim mesmo assim informa que o mail foi enviado

Retirei o On Error Resume Next e é igual

Obrigado

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
https://www.maximoaccess.com/t30190-opcao-error-trapping-interceptacao-de-erro

Abraço

Igual

Boa tarde, Assis
Ainda está por resolver?

Bom dia Alexandre

Sim igual.

Bom dia, Assis
Mude o procedimento de envio para função
passa de sub Envia para função (Function EnviaCE(argumentos)as boolean)
onde tem err=0 acrescentas EnviaCE=True

Ao executar a função, ele devolve Sim ou Não e a partir daí dá para gerir o que pretende fazer a seguir
Se precisares que tente adaptar o teu código dá um alerta

Olá a todos,

Alexandre o colega Assis, pediu ajuda (MP) para implementar a ideia da mensagem n. 10
Creio que seja dentro disto com base o código da mensagem n. 1:

Código:

Sub QueNaoSabemosNomeDoSeuProjeto()

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
    
    If EnviaCE = True Then 'alteracao
       'Inserindo o mail
       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
        
         'Call EnviarEmail passou para if com fincao nova

        'Assis acho deveria fechar o recordset
        TabLancamentos.Close
        Set TabLancamentos = Nothing
    End If
Final:
    Else
        MsgBox "Cancelar Gravação do Mail ?", vbCritical, "@Mail não será Enviado"
        Call btnLimpar_Click
        Me.txtPara.SetFocus
      
    End If
End Sub

Function EnviaCE() As Boolean

    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": EnviaCE = True  'alteracao
    
    DoCmd.Close acForm, "frmProgresso"
    
    DoCmd.Close acForm, "email"
    
    Set emailobj = Nothing
    Set emailConfig = Nothing

End Function

Assis, o colega Alexandre Neves não tem MP ativado, mas era só fazer como referiu "Se precisares que tente adaptar o teu código dá um alerta" no tópico.

Boa noite,
É dentro disso amigo Teixeira
Com esse resultado da função EnviaCE, caso seja True a mensagem foi enviada e fará o tratamento de registo pretendido, caso contrário, considera não enviada a mensagem

Boa noite Amigos

Devia dar erro ao detetar erro no email do destinatário (coloquei  anibal.assis@sapo.ptt )

O final do endereço coloco errado  de propósito e não deteta .


Continua a informar a  MsgBox "@Mail Enviado com Sucesso"

Obrigado

Bom dia Amigos

Assis, como ja referi, o codigo não dá erro de envio o "cdo" enviou o email sem qualquer erro.
Como enviou para um email inexistente, neste caso o servidor de recepção de email da sapo, vai responder com uma mensagem automática para o servidor que enviou e por sua vez ao respetivo email que enviou.

Portanto a meu ver a única forma séria verificar as mensagens recebidas na caixa de email.

Aguardamos se algum colega tem outra opinião e solução.

Abraço a todos