Office: (Office 2013) Tabelle aus Excel über VBA in Outlook mit Formatierung übertragen

Hallo zusammen,
ich bin langsam am verzweifeln, da ich bisher nichts passendes gefunden habe.

Kurz zur Erklärung: Über einen Button soll eine Einladung zu einem Termin via Outlook generiert werden. Die einzelnen Informationen zu Ort, Datum, Uhrzeit usw werden aus verschiedenen Zellen gezogen. Dank einer Vorlage im Internet funktioniert das auch soweit ganz gut. Bis auf der Langtext, welchen ich über .HTMLBody einfügen möchte und zwar mit der Tabellenformatierung wie sie bei Excel besteht. Bisher lässt er das Feld einfach nur frei.

Lustiger Weise funktioniert es, wenn ich statt einem Termin eine E-Mail versenden möchte, dementsprechend statt
Set OutMail = OutApp.createItem(1)
einfach
Set OutMail = OutApp.createItem(0)
eintrage.

Hier einmal mein Code dazu:

Code:

Sub Schaltfläche36_Klicken()
Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("Einladung").Range("A14:J16").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.createItem(1)

    On Error Resume Next
    With OutMail
    .BodyFormat = olFormatHTML
    .HTMLBody = RangetoHTML(rng)
      Dim sAddress As String
    sAddress = Worksheets("Grunddaten").Range("b7").Value

    .Subject = Sheets("Einladung").Range("b3").Value
    .Start = Sheets("Einladung").Range("b6").Value + Sheets("Einladung").Range("d6").Value
    .Location = Sheets("Einladung").Range("b5").Value
    .Duration = "60"
    .ReminderMinutesBeforeStart = 15
    .ReminderPlaySound = True
    .ReminderSet = True
    Set olrecip = .Recipients.Add(sAddress)
    '.send
    .Save
    .display

     .display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub



Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Kann mir jemand weiterhelfen? Ich wunder mich vor allem, dass es mit der E-Mail funktioniert, aber nicht als Termin

Vielen Dank im Voraus

 

Hat hier niemand eine Idee?