|
Unten mein Quellcode für das versenden einer Seirienmail mit Anhang über SMTP.
Das versenden funktioniert einwandfrei, aber es wird jedesmal der Anhang wieder mit angehängt.
Hat jemand eine Idee das dies nicht mehr passiert.
Private Sub cmdAuswaehlen_Click()
Dim ctlAnhang As String
Dim objFiledialog As Office.FileDialog
Set objFiledialog = FileDialog(msoFileDialogFilePicker)
If objFiledialog.Show = True Then
Me.ctlAnhang = objFiledialog.SelectedItems(1)
Else
Debug.Print "Keine Datei auswählt"
End If
End Sub
Private Sub cmdSend_Click()
On Error GoTo errHandler
Dim cdoconfig As Object
Dim cdoMessage As Object
Dim db As DAO.Database
Dim rs As DAO.Recordset
'check form input
If Me.txtServer & "" = "" Then
Me.txtServer.SetFocus
MsgBox "Please enter the server's address", vbInformation, "Required"
ElseIf Not IsNumeric(Me.txtPort) Then
Me.txtPort.SetFocus
MsgBox "Please enter a port number.", vbInformation, "Required"
ElseIf Me.txtUsername & "" = "" And Me.txtAuth > 0 Then
Me.txtUsername.SetFocus
MsgBox "Please enter your username.", vbInformation, "Required"
ElseIf Me.txtPwd & "" = "" And Me.txtAuth > 0 Then
Me.txtPwd.SetFocus
MsgBox "Please enter the password.", vbInformation, "Required"
ElseIf Me.txtFrom & "" = "" Then
Me.txtFrom.SetFocus
MsgBox "Please enter your email address.", vbInformation, "Required"
'ElseIf Me.txtTo & "" = "" Then
' Me.txtTo.SetFocus
' MsgBox "Please enter the recipient's email address.", vbInformation, "Required"
ElseIf Me.txtSubj & "" = "" Then
Me.txtSubj.SetFocus
MsgBox "Please enter a subject line.", vbInformation, "Required"
ElseIf Me.txtMsg & "" = "" Then
Me.txtMsg.SetFocus
MsgBox "Please enter a message.", vbInformation, "Required"
Else
'create email object
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT EMail FROM Mitglieder")
Set cdoconfig = CreateObject("CDO.Configuration")
Set cdoMessage = CreateObject("CDO.Message")
'setup server configuration
With cdoconfig.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Me.txtServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Me.txtPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = Me.txtAuth
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = Me.txtSendUsing
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = Me.txtSSL
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = Me.txtTimeout
.Item("http://schemas.microsoft.com/cdo/configuration/smtpAddAttachment") = Me.ctlAnhang
'following settings are optional
'.Item("http://schemas.microsoft.com/cdo/configuration/smtpaccountname") = "The DB Guy"
'.Item("http://schemas.microsoft.com/cdo/configuration/sendemailaddress") = "thedbguy@gmail.com"
'.Item("http://schemas.microsoft.com/cdo/configuration/cdoReturnReceiptTo") = "alexander.wendt@online.de"
'warning: it's a security risk to hard-code your username and password
If Me.txtAuth > 0 Then
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Me.txtUsername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Me.txtPwd
End If
.Update
End With
'build and send email message
If IsNull(Me.ctlAnhang) Then
Do Until rs.EOF
If IsNull(rs.Fields("EMail").Value) Then
rs.MoveNext
Else
With cdoMessage
Set .Configuration = cdoconfig
.From = Me.txtFrom
.To = rs.Fields("EMail").Value
'.Cc = "copy@email.address"
'.Bcc = "blind.copy@email.address"
.Subject = Me.txtSubj
.TextBody = Me.txtMsg
'.HTMLBody = "<h2>Use this to send email as HTML.</h2>"
'.AddAttachment txtdatei
.Send
rs.MoveNext
End With
End If
Loop
Else
Do Until rs.EOF
If IsNull(rs.Fields("EMail").Value) Then
rs.MoveNext
Else
With cdoMessage
Set .Configuration = cdoconfig
.From = Me.txtFrom
.To = rs.Fields("EMail").Value
'.Cc = "copy@email.address"
'.Bcc = "blind.copy@email.address"
.Subject = Me.txtSubj
.TextBody = Me.txtMsg
'.HTMLBody = "<h2>Use this to send email as HTML.</h2>"
.AddAttachment ctlAnhang
.Send
ctlAnhang = ""
rs.MoveNext
End With
End If
Loop
End If
End If
MsgBox "Alle E-Mail wurde gesendet!!!!", vbInformation, "Erledigt!!!!!"
Set cdoconfig = Nothing
Set cdoMessage = Nothing
Exit Sub
errHandler:
MsgBox Err.Number & ": " & Err.Description
MsgBox "Alle E-Mail wurde gesendet!!!!", vbInformation, "Erledigt!!!!!"
errExit:
Set cdoconfig = Nothing
Set cdoMessage = Nothing
Exit Sub
End Sub
|