Text aus verschiedenen Zelleninhalten erstellen
14.02.2018 18:46:20
Marcel
ich brauche mal wieder etwas VBA Unterstützung.
Ich sende aus Excel eine Email, was auch prima funktioniert.
Leider gelingt mir das Einfachste nicht.
Der Text in der Email soll übersichtlich untereinander die Basisinformationen liefern. Leider gelingt mir das nur als Einzeiler.
Wie es aussehen sollte, habe ich als Kommentar eingefügt.
Danke im Voraus
Marcel
Sub SendAutoMail()
Dim sText As String
Dim sTo As String
Dim sCC As String
Dim sSubject As String
Dim aws As String
sTo = ""
sCC = ""
sText = ""
sSubject = ""
Dim lRow As Long
Dim r As Range
With Sheets("Meldungen")
lRow = .Cells(.Rows.Count, 8).End(xlUp).Row
If lRow >= 100 Then 'ab Zeile 100
For Each r In .Range("H101:H" & lRow)
If r.Value = "SENDEBEREIT" Then 'SENDEBEREIT IN H
r.Value = "GESENDET"
r.Offset(0, 22).Value = Now & " " & Application.UserName 'Datum eintragen und User eintragen
'sSubject = r.Offset(0, 1).Value
sSubject = "No_" & r.Offset(0, -6) & "_" & r.Offset(0, -5) & "_" & r.Offset(0, 12) & "_" & r.Offset(0, 4) & "_" & r.Offset(0, 3) & "_TO_" & r.Offset(0, -1) & "_" & r.Offset(0, 1) & "_" & r.Offset(0, 6)
'HIER KOMMT MEIN PROBLEM
'Der Text in der Email soll übersichtlich dargestellt sein und stellt sich aus verschiedenen Zellen zusammen. Im Ergebnis soll es dann so aussehen
'Sehr geehrte Damen und Herren, ENTER
'anbei erhalten Sie die Meldung & r.Offset(0, 4) ENTER
'ENTER
'"MENGE: "& r.Offset(0, 5) ENTER
'"KOSTEN: "& r.Offset(0, 6) ENTER
'"ANSPRECHPARTNER: "& r.Offset(0, 7) ENTER
'USW. mit weiteren Infos aus r.Offset (0, xx)
'Trotz sText = sText & "Ladies and ...." & vbCr & vbLf & vbCr & vbLf kommt es immer als Einzeiler ohne ENTER :-(
sTo = r.Offset(0, 8).Value
If r.Offset.Value "" Then
aws = r.Offset(0, 9)
End If
Call SendSheetOutlook(sSubject, sTo, sCC, sText, aws)
End If
Next r
End If
End With
End Sub
Private Sub SendSheetOutlook(sSubject As String, sTo As String, sCC As String, sText As String, _
aws As String)
Dim olApp As Object
Dim olOldBody As String
'Dim Nachricht As Object, OutApp As Object 'NEU
'Dim r As Range
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldBody = .htmlBody
.To = sTo
.cc = sCC
.Subject = sSubject
If aws "" Then
.attachments.Add aws 'NEU
End If
.htmlBody = sText & olOldBody
'.send
End With
End Sub