Versand von Email per CDO.Message fehlerhafte Email Protokollieren

Private Sub Befehl_Senden_Click()
Dim objNachrich As MailItem
Dim EMailbetreff As String
Dim EMail_orginal As String
Dim Email As String
Dim anzahlmail As String
Dim empfänger As String
Dim db As Database
Dim Rs As Recordset
Call IPH

If [Betreff] = "" Or [Mailtext] = "" Then  
MsgBox "Sie haben noch keine E-Mail erstellt"  
Exit Sub
End If

'Öffne vorlage  
EMailbetreff = [Betreff]
EMailVorlage = [Mailtext]
'Öffne vorlage Ende  
  
  
   Set objMessage = CreateObject("CDO.Message")  
   
   Call CDO_config
   
  With objMessage.Configuration.Fields
    '==This section provides the configuration information for the remote SMTP server.  
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = sendusing           '==Normally you will only change the server name or IP.  
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpserver         'Name or IP of Remote SMTP Server  
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = smtpserverport 'Server port (typically 25)  
    .Update
    '==End remote SMTP server configuration section==  
  End With
  
'Auslesen Anzahl E-Mail Adressen  
    Set db = CurrentDb()
    Set Rs = db.OpenRecordset("Email", dbOpenDynaset)  
    Rs.MoveLast             ' <-- wichtig, sonst 'RecordCount' evtl. falsch  
    iMaxZeile = Rs.RecordCount
    Rs.MoveFirst
    MsgBox "Es werden: " & iMaxZeile & " E-mails gesendet"  
'Auslesen Anzahl E-Mail Adressen Ende  
     
'Senden  
  'Schleife  
  
    For w = 1 To 10
     If eAnhang(w) <> "" Then  
     objMessage.AddAttachment eAnhang(w) 'Anhang aus formular  
     End If
    Next
    
  For i = 1 To iMaxZeile
     
    Email = Replace(EMailVorlage, "[Anrede]", Rs.Fields("Anrede") & "")  
    Email = Replace(Email, "[Anrede-Anschreiben]", Rs.Fields("Anrede-Anschreiben") & "")  
    Email = Replace(Email, "[Vorname]", Rs.Fields("Vorname") & "")  
    Email = Replace(Email, "[Name]", Rs.Fields("Nachname") & "")  
    Email = Replace(Email, "[Autohaus]", Rs.Fields("Autohaus") & "")  
  
    'Set objMessage = CreateObject("CDO.Message")  
    With objMessage
     .Subject = EMailbetreff
     .Sender = Sender   ' Absender  
     .From = SenderName ' Absendername  
     .To = Rs.Fields("E-Mail")  
     .HTMLBody = Email
     '.Send  'Senden E-Mail  
     On Error Resume Next
     .Send
                   ' If Err.Number <> 0 Then  
                   ' MsgBox Rs.Fields("E-Mail")  
                   If (Err.Number = -2147220977) Then
                   MsgBox "Die E-Mail Adresse " & Rs.Fields("E-Mail") & " konnte nicht versendet werden:" & vbNewLine & vbNewLine & Err.Description  

                        
                        'Response.Write ("Error sending email to " & Rs.Fields("E-Mail") & "<br />")  
                        
                        Err.Clear
                    End If
                On Error GoTo 0
    End With
    empfänger = empfänger & Rs.Fields("E-Mail") & "; "  
    Rs.MoveNext
  Next
 'Schleife ende  
    Rs.Close
    db.Close
    
MsgBox " Emails erfolgreich versendet!"  
 
 Set db = CurrentDb
 Set Rs = db.OpenRecordset("09_Gesendete-Mails")  
    
    With Rs
       .AddNew
       !Betreff = EMailbetreff
       !Nachricht = EMailVorlage
       !Mailadresse = empfänger
       .Update
       .Bookmark = Rs.LastModified
    End With
    
    Rs.Close
 db.Close


DoCmd.Close
End Sub