Sub Kalender_Einträge() '(ByVal KalenderName As String)
    ' Wichtige Tabelleneinträge ansehen
    ' Erstellt am 22.05.1006 durch Oliver Wintzek www.wintzek.com

    'Damit dies funktioniert muss "Microsoft CDO..." in die Verweise aufgenommen werden!

    Dim I As Long
    Dim msg As String
    
    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim Kal_Ordner As Object
    Dim Akt_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
    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
    For I = .Items.Count To 1 Step -1
    
        Dim myItems As Object
        Set myItems = Kal_Ordner.Items(I)
        
        'Für Beschriftung ************************
        Set objMsg = objCDO.GetMessage(myItems.EntryID, myItems.Parent.StoreID)
        Set colFields = objMsg.Fields
        Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1)
        
        Dim Beschriftung As String
        Select Case objField.Value
        Case 0
            Beschriftung = ""
        Case 1
            Beschriftung = "Wichtig"
        Case 2
            Beschriftung = "Geschäftlich"
        Case 3
            Beschriftung = "Privat"
        Case 4
            Beschriftung = "Urlaub"
        Case 5
            Beschriftung = "Teilname erforderlich"
        Case 6
            Beschriftung = "Anreise einplanen"
        Case 7
            Beschriftung = "Vorbereitung notwendig"
        Case 8
            Beschriftung = "Geburtstag"
        Case 9
            Beschriftung = "Jahrestag"
        Case 10
            Beschriftung = "Telefonanruf"
        Case Else
            Beschriftung = ""
        End Select
        
        
        Dim AnzeigeAls As String
        Select Case myItems.BusyStatus
        Case olFree
            AnzeigeAls = "Frei"
        Case olTentative
            AnzeigeAls = "Unter Vorbehalt"
        Case olBusy
            AnzeigeAls = "Gebucht"
        Case olOutOfOffice
            AnzeigeAls = "Abwesend"
        End Select
        
        Dim Zeitraum As String
        Select Case myItems.GetRecurrencePattern.RecurrenceType
        Case 1
            Zeitraum = "täglich"
        Case 2, 3
            Zeitraum = "monatlich"
        Case 4
            Zeitraum = "wöchentlich"
        Case 5, 6
            Zeitraum = "jährlich"
        Case Else
            Zeitraum = "in Serie"
        End Select
        
        
        msg = ""

        msg = msg & _
               "Erstellt am : " & myItems.CreationTime & vbCr & _
               "Letzte Änderung : " & myItems.LastModificationTime & vbCr & _
               vbCr
               
        msg = msg & _
               "Wichtigkeit / Priorität: " & myItems.Importance & vbCr & _
               "Categories : " & myItems.Categories & vbCr & _
               "Vertraulichkeit (Privat) : " & myItems.Sensitivity & vbCr & _
               "Zeitraum ist (" & Str(myItems.BusyStatus) & " ) : " & AnzeigeAls & vbCr & _
               "Besprechungs-Status : " & myItems.MeetingStatus & vbCr & _
               "Beschriftung (" & Str(objField.Value) & " ) : " & Beschriftung & vbCr & _
               vbCr

        msg = msg & _
               "Start-Zeitpunkt : " & myItems.Start & vbCr & _
               "Ende-Zeitpunkt : " & myItems.End & vbCr & _
               "Dauer des Termins : " & myItems.Duration & vbCr & _
               vbCr
               
        msg = msg & _
               "Erinnerung vorher : " & myItems.ReminderMinutesBeforeStart & vbCr & _
               "Erinnerungs-Standartwert : " & myItems.ReminderOverrideDefault & vbCr & _
               "Erinnerungs-Sound : " & myItems.ReminderPlaySound & vbCr & _
               "Erinnerungs-Datei : " & myItems.ReminderSoundFile & vbCr & _
               "Erinnerung : " & myItems.ReminderSet & vbCr & _
               vbCr
               
        msg = msg & _
               "Zeitraum ist Serien : " & myItems.IsRecurring & vbCr & _
               "Serien-Beginn : " & myItems.GetRecurrencePattern.PatternStartDate & vbCr & _
               "Serien-Ende   : " & myItems.GetRecurrencePattern.PatternEndDate & vbCr & _
               "Der Termin ist (" & Str(myItems.GetRecurrencePattern.RecurrenceType) & " ) " & Zeitraum & vbCr & _
               "Ganztägig : " & myItems.AllDayEvent & vbCr & _
               vbCr
               
        msg = msg & _
               "Notiz : " & myItems.Body & vbCr & _
               "Betreff : " & myItems.Subject & vbCr & _
               "Ort : " & myItems.Location & vbCr & _
               vbCr

        msg = msg & _
               "Mileage : " & myItems.Mileage & vbCr & _
               "Session : " & myItems.Session & vbCr & _
               "Nachrichten-Klasse : " & myItems.MessageClass & vbCr & _
               "Class: " & myItems.Class & vbCr & _
               "Display : " & myItems.Display & vbCr & _
               "Entry-ID : " & myItems.EntryID & vbCr & _
               "Store-ID : " & myItems.Parent.StoreID

                    
        
            msg = msg & vbCr & "Wollen Sie den Eintrag löschen?"
            
            
            If MsgBox(msg, vbExclamation Or vbYesNoCancel Or vbDefaultButton2, "Löschen") = vbYes Then
                myItems.Close 0 ' Kontakt schließen
                Kal_Ordner.Items(I).Delete 'Eintrag löschen
            Else
                myItems.Close 0 ' Kontakt schließen
            End If
            
                      
     Next I
    
    End With
    

End Sub