Outlooktermin mit HTML-Body erzeugen
19.06.2022 22:06:03
Kalle
wie man eine Email aus Excel mit Tabellen und Bildern exportiert, habe ich bereits verstanden in einigen Projekten implementiert. Nun würde ich gerne einen Outlook-Termin erzeugen, der im .body HTML-Tags erkennt. Meinen bisherigen Recherchen zufolge scheint das alles andere als einfach via VBA umsetzbar zu sein, wenngleich man Bilder und Formatierungen "händisch" in jeden Termin via Outlook-Frontend einfügen kann. Hier mein Code und die stark verschlankte Datei:
Sub Termin_Export()
Dim myDictAllEmail, myDictSendEmail As Object
Dim DictKey As Variant
Dim TempFilePath, xHTMLBody, emailList As String
Dim xRg, rng, myCell, rngAusbilder As Range
Dim lastRow, i, foundEmails As Long
Set myDictAllEmail = CreateObject("Scripting.Dictionary")
Set myDictSendEmail = CreateObject("Scripting.Dictionary")
Set rngAusbilder = Nothing
On Error Resume Next
'Email-Verteiler erzeugen
With ActiveSheet
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastRow " _
& "" _
& "Liebe Kolleginnen und Kollegen,
" _
& "
" _
& "[PLATZHALTER FÜR INFOTEXT TESTLEITUNG]" _
& "
" _
& "" _
& "
Freundliche Grüße"
.Start = Format((Date + 1), "dd.mm.yyyy") & " 09:00"
.Duration = "60"
.Subject = "Betreff"
.body = HTMLBody
.Location = "Ort"
.Recipients.Add (emailList)
.Attachments.Add TempFilePath & "Testplanung.jpg", olByValue
.ReminderPlaySound = True
.ReminderSet = True
.Display
End With
End Sub
Sub createJpg( SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
' Call FreigabeAusschalten
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
' Call FreigabeEinschalten
End Sub
Datein: https://www.herber.de/bbs/user/153654.xlsm
Es werden eine Grafik der Testplanung und ein passender Email-Verteiler erzeugt (warum immer 1 user unknow bleibt, keine Ahnung). Beides soll zukünftig nicht als Email sondern gleich als Testtermin vesendet werden können.
Hoffe, Ihr könnt mir erneut weiterhelfen.
LG Kalle