Sub KalenderEintrag(ByVal KalenderName As String)
        ' Kalendereintrag erstellen
    ' Erstellt am 22.05.2006 durch Oliver Wintzek  www.wintzek.com
    ' Damit dieses Makro funktioniert, sollten Sie "Microsoft CDO..." über die Verweise aufnehmen
    Dim msg As String
    
    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim Kal_Ordner As Object
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")

    Set Akt_Ordner = myNameSpace.GetDefaultFolder(olFolderCalendar) 'Kalender auswählen
    
    If KalenderName > "" Then
        Set Kal_Ordner = Akt_Ordner.Folders(KalenderName) 'Unterordner wählen falls vorhanden
    Else
        Set Kal_Ordner = Akt_Ordner.Session.PickFolder 'Ordner auswählen
    End If

    ' Für Beschriftung ********************
    Const CdoPropSetID1 = "0220060000000000C000000000000046"
    Const CdoAppt_Colors = "0x8214"
    Dim objMsg As MAPI.Message
    Dim objCDO As MAPI.Session
    Dim objField As MAPI.Field
    Dim colFields As MAPI.Fields
    Dim objExpl As Outlook.Explorer
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
        
    'Öffne Ordner-Dialog zum Auswählen des Kontakte-Ordners
    'Set myFolder = Session.PickFolder
    With Kal_Ordner.Items.Add
        .Start = "21.05.2006 21:02:07"
        .End = "21.05.2006 22:14:33"
        .ReminderMinutesBeforeStart = 15 'Erinnerung vorher
        .ReminderSet = True 'Erinnerung anschalten
        .Subject = "Hier ist der Betreff"
        .Location = "Ort des Termines"
        .Body = "Hier steht die Notiz des Termins eine kleine Erläuterung"
        .Save
        
        'Für Beschriftung ************************
        Set objMsg = objCDO.GetMessage(.EntryID, .Parent.StoreID)
        Set colFields = objMsg.Fields
        Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1)
        objField.Value = 2
        objMsg.Update True, True
    End With
       
    'Call Kalender_Einträge(KalenderName)

End Sub