Mit Excel 2010 (VBA) eine Mail erzeugen und als Anlage einen Termin erstellen

Sub Mailing_und_Termin()
    
   
   
    Dim rng As Range
    Dim OutApp As Object
    Dim OutApptmt As Object
    Dim OutMail As Object
    Dim olOldBody As String
    Dim Beschreibung As String
    Dim Beschreibung1 As String
    Dim Beschreibung2 As String
    Dim Beschreibung3 As String
    Dim Beschreibung4 As Date
    Dim Beschreibung5 As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
 
    Set OutApp = CreateObject("Outlook.Application")  
 
    Beschreibung = Sheets("Tabelle1").Range("c1")  'FD  
    Beschreibung1 = Sheets("Tabelle1").Range("c2") 'Vertrags-Nr  
    Beschreibung2 = Sheets("Tabelle1").Range("c3") 'Vertragspartner  
    Beschreibung3 = Sheets("Tabelle1").Range("c4") 'Vertragsgegenstand  
    Beschreibung4 = Sheets("Tabelle1").Range("c5") 'T für Wvl  
    Beschreibung5 = Sheets("Tabelle1").Range("c6") 'Grund für Wvl  
    
    Set OutApptmt = OutApp.CreateItem(1)
    With OutApptmt
     
    
        .Subject = "Veränderung in den Wvl. der Vertragsdaten"  
        .Start = Beschreibung4
        '.Start = Now + 1  
        '.End = DateAdd("h", 1, .Start)  
        .AllDayEvent = True
        .Body = Beschreibung & Chr(13) & Chr(13) _
            & "Vertrag-Nr.:" & String(30, " ") & Beschreibung1 & Chr(13) _  
            & "Vertragspartner:" & String(21, " ") & Beschreibung2 & Chr(13) _  
            & "Vertragsgegenstand:" & String(12, " ") & Beschreibung3 & Chr(13) _  
            & "Termin für Wvl.:" & String(22, " ") & Beschreibung4 & Chr(13) _  
            & "Grund für Wvl.:" & String(23, " ") & Beschreibung5 & Chr(13) & Chr(13) _  
            & String(12, " ") & "eingetragen am:    " & Date  
            
            
        .MeetingStatus = 1  '1=olMeeting  
        '.RequiredAttendees = "max.mustermann@muster.com"  
        .Save
        Set OutMail = .ForwardAsVcal
    End With
 
    'On Error Resume Next  
    With OutMail
        .GetInspector.display
        olOldBody = .HTMLBody
        .To = "max.muster@icloud.com"  
        .cc = ""  
        .bcc = ""  
        .Subject = "Terminveränderung im Vertragsregister des FD 30"  
        .HTMLBody = RangeToHTML(Sheets("Tabelle1").Range("A8:d20"))  
        .display
        .Send
    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"  
    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 GoTo 0
    End With
    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
    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=")  
    TempWB.Close SaveChanges:=False
    Kill TempFile
    Set ts = Nothing
    Set Fso = Nothing
    Set TempWB = Nothing
End Function