Outlook-Mail Erzeugung klappt nicht mehr :-(
12.12.2017 18:11:41
Nordwestler
Ich hatte einen funktionierenden Code im Einsatz, der eine Mail in Outlook erzeugte und von Mailadresse über Anrede bis Signatur komplett und korrekt erstellte. Nun habe ich die Abfragen für die Datenbasis umgebaut, die aber nichts mit den Inhalten zu tun haben, aus denen die Mail erstellt wird.
Und trotzdem zieht Outlook auf einmal die Anrede und die beiden Textbausteine nicht mehr aus den definierten Zellen D8,D9,D10, sondern zieht dreimal den Inhalt aus B2 in den Textbereich der Mail - warum auch immer!?
Hat jemand eine Idee, woran das liegen kann und wie ich diese "Eigenmächtigkeit" wieder beheben kann?
Hier der Code: (Ich weiß nicht, warum sich mitten drin die Formatierung ändert :-()
Sub Mail_in_Outlook_erzeugen_und_mit_Anhang_versenden()
Dim boSchalter As Boolean
Dim strAttachmentPfad1 As String
Dim strAttachmentPfad2 As String
Dim strAttachmentPfad3 As String
Dim strDateiname As String
Dim strSignatur As String
Dim olApp As Object
Dim olMail As Object
Dim wkS As Worksheet
Dim olFormatHTML As Object
Set wkS = ThisWorkbook.Worksheets(2)
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
With olMail
' Empfängeradressen holen aus Zeile 11, 12, 13 und 14, Spalte 4 (D11 -D14)
.To = Cells(11, 4) & ";" & Cells(12, 4)
.Cc = Cells(13, 4) & ";" & Cells(14, 4)
' Betreff holen
.Subject = Cells(7, 4)
' Outlook Signatur aktivieren
.GetInspector.Display
strSignatur = .HTMLBody
' Formatiert Text in HTML
.BodyFormat = 2
.HTMLBody = ""
.HTMLBody = .HTMLBody & ""
.HTMLBody = .HTMLBody & wkS.Cells(10, 4).Text & "
" ' Anrede
.HTMLBody = .HTMLBody & "
" & "
" ' 2 Leerzeilen
.HTMLBody = .HTMLBody & wkS.Cells(8, 4).Text & "
" ' Textzeile 1 & Neue Zeile
.HTMLBody = .HTMLBody & "
" ' 1 Leerzeile
.HTMLBody = .HTMLBody & wkS.Cells(9, 4).Text & "
" ' Textzeile 2 & Neue Zeile
.HTMLBody = .HTMLBody & "
" & strSignatur ' 1 Leerzeile & Outlook- _
Signatur
.HTMLBody = .HTMLBody & ""
' prüft, ob Anlagen in angegebenen Zellen vorhanden sind
If Range("G4") "" Then
strDateiname = Range("G4").Value
strAttachmentPfad1 = Environ("USERPROFILE") & "\Desktop\Exceltest\Ergebnisse\" & _
strDateiname
boSchalter = True
End If
If Range("D15") "" Then
strDateiname = Range("D15").Value
strAttachmentPfad2 = Environ("USERPROFILE") & "\Desktop\Exceltest\Anlagen\" & _
strDateiname
boSchalter = True
End If
If Range("D16") "" Then
strDateiname = Range("D16").Value
strAttachmentPfad3 = Environ("USERPROFILE") & "\Desktop\Exceltest\Anlagen\" & _
strDateiname
boSchalter = True
End If
If boSchalter Then
If Not strAttachmentPfad1 = "" Then
.Attachments.Add strAttachmentPfad1
End If
If Not strAttachmentPfad2 = "" Then
.Attachments.Add strAttachmentPfad2
End If
If Not strAttachmentPfad3 = "" Then
.Attachments.Add strAttachmentPfad3
End If
End If
'Mail anzeigen vor Versand
.Display
End With
'Outlook schliessen
'OutApp.Quit
Set olMail = Nothing
Set olApp = Nothing
Set Nachricht = Nothing
End Sub