AW: CDO Mail - Führt nicht immer alles aus
04.07.2019 12:26:19
LeFagnard
Hier noch der Code dazu:
Sub CDO_Mail(intAbsender As Integer)
Dim iMsg As Object
Dim iConf As Object
Dim fso As Object
Dim objBP As Object
Dim strBodyHtml As String
Dim Flds As Variant
Dim intLastZeile As Integer
Dim i As Integer
Dim j As Integer
Dim strBetreff As String
Dim boolTernell As Boolean
Dim boolWander1_5 As Boolean
Dim boolWander6 As Boolean
'Application.ScreenUpdating = False
intLastZeile = Anmeldung.Cells(Rows.Count, 7).End(xlUp).Row 'Ermittlung der letzten _
beschriebenen Zeile (Zieldatei)
If intLastZeile 9 Then
MsgBox "Nicht alle Mails wurden versendet." & vbCrLf & "Bitte starten Sie die _
Prozedur ein weiteres Mal.", , "ACHTUNG"
Exit For
End If
Call MailHtmlErstellen(i, strBetreff, boolTernell, boolWander1_5, boolWander6)
Set fso = CreateObject("Scripting.FileSystemObject")
strBodyHtml = fso.OpenTextFile("Y:\Spaces\Versailles2019\mail.html", 1).ReadAll
Set iConf = CreateObject("CDO.Configuration")
Set iMsg = CreateObject("CDO.Message")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = Preise.Cells(intAbsender, _
15)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Preise.Cells(intAbsender, _
13)
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Preise.Cells(intAbsender, _
14)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Preise.Cells(intAbsender, _
12)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Preise.Cells( _
intAbsender, 16)
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Update
End With
With iMsg
Set .Configuration = iConf
.To = LCase(Anmeldung.Cells(i, 11))
.CC = ""
.BCC = LCase(Preise.Cells(intAbsender, 17))
.From = LCase(Preise.Cells(intAbsender, 17))
.Subject = strBetreff
.HTMLBody = "" & Umlaut(strBodyHtml)
If boolTernell Then: .AddAttachment "Y:\Spaces\Versailles2019\Ternell_pause.jpg" _
.AddRelatedBodyPart "Y:\Spaces\Versailles2019\mail.gif", "logo.gif", 0
.Fields.Item("urn:schemas:mailheader:Content-ID") = "logo.gif"
.Fields.Update
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
Set fso = Nothing
Set iConf = Nothing
Anmeldung.Cells(i, 1) = "ja"
If Not boolWander1_5 And boolWander6 Then: Anmeldung.Cells(i, 2) = "ja"
End If
Application.CutCopyMode = False
Next i
Anmeldung.Activate
'Application.ScreenUpdating = True
End Sub