Public Function CreateOutlookAppointment(SDate, Optional EDate = "", Optional _
  Subject = "", Optional Body = "", Optional Erinnerung = "", Optional Ort = "")
    Dim myOlApp As Object, Tmp, I As Long, j As Long, aItm As AppointmentItem, _
    myNameSpace As Object
    Dim myFolder As Object, UProp As Outlook.UserProperty, IsOpen As Boolean
    On Error Resume Next
    Set myOlApp = GetObject(, "Outlook.Application")
    IsOpen = False
    If Err = 0 Then
        IsOpen = True
    Else
        Err.Clear
        On Error GoTo Er
        Set myOlApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo Er
        ' Neuen Termin anlegen
        Set aItm = myOlApp.CreateItem(olAppointmentItem)
        With aItm
        .Subject = Subject
        .Body = Body
        .Start = CDate(SDate)
        .Location = Ort
        .ReminderSet = True
        .ReminderMinutesBeforeStart = CInt(Erinnerung)
        If EDate = "" Then
            .End = DateAdd("h", 1, .Start)
        Else
            .End = CDate(EDate)
        End If
        .Display        ' oder .Save
        End With
Ex:
        On Error Resume Next
        Set myFolder = Nothing
        Set myNameSpace = Nothing
        If IsOpen Then Set myOlApp = Nothing
        Exit Function
Er:
        MsgBox "CreateOutlookAppointment: " & Err & " " & Err.Description
        GoTo Ex
End Function