Zeitraumbeschränkung:Outlook Kalender über Makro in Excel auslesen

mollyca

Grünschnabel
Hallo Zusammen,

ich bin gerade dabei ein Makro in Excel zusammen zu basteln, um meine Termine aus dem Outlook-Kalender in einer Excel Tabelle auszulesen. Dafür habe ich auch schon hier im Forum einen Code gefunden (s. unten). Das einzige Problem ist, dass nicht nur meine aktuellen bzw. anstehenden Termine ausgelesen werden, sondern auch alle meine vergangenen Termine aus den vorherigen Jahren (reicht bis zu 10 Jahre zurück). Dadurch stürzt Excel bei der Übertragung ab... Wisst ihr wie ich den Zeitraum beschränken kann, bzw. nur den Outlook Kalender aus einem bestimmten Zeitraum auslesen kann?

Ich habe leider keine Ahnung von VBA und finde da leider auch keine Lösung für... Würde mich freuen, wenn ihr mir helfen könntet...

Public Sub kal_imp()

Set Outl_App = CreateObject("Outlook.Application")
Set Namens_R = Outl_App.GetNamespace("MAPI")
Set Akt_Ordner = Namens_R.GetDefaultFolder(olFolderCalendar) 'Kalender auswählen
Set Kal_Ordner = Akt_Ordner
Set Element_kal = Kal_Ordner.Items

'***

Cells(1, 1) = "Termin"
Cells(1, 2) = "Thema"
Cells(1, 3) = "Sonstige Bemerkungen"

For i = 1 To Element_kal.Count
Cells(i + 1, 1) = Element_kal(i).Start
Cells(i + 1, 2) = Element_kal(i)

'... weitere Eigenschaften im Objektkatalog unter "AppointmentItem"

Next i

'Objekte freigeben

Set Outl_App = Nothing
Set Namens_R = Nothing
Set Akt_Ordner = Nothing
Set Kal_Ordner = Nothing
Set Element_kal = Nothing

End Sub
 
Am einfachsten filtern. Aber zuerst noch sicherstellen, dass die Dauaertermine als einzelne Termine übernommen werden
Hier eine Funktion, die den Start der Termine einschränkt
Visual Basic:
'/**
' * Schreibt Termine eines Zeitabschnittes in das Direktfenster
' * @example    dpOutlookAppointments #4/1/2016 12:00#,  #4/5/2016#
' * @param  Date    StartDatum
' * @param  Date    EndDatum
' */
Public Sub dpOutlookAppointments(ByVal iFromDate As Date, ByVal iToDate As Date)
    Dim otl As New Outlook.application
    Dim ns As Outlook.Namespace
    Dim cal As Outlook.Folder
    Dim apps As Outlook.itemS
    Dim app As Outlook.AppointmentItem
    Dim filter As String
            
    'Datum/Zeit Format für den Filter
    'Das Datum muss im PC/Länder speziefischen Format sein. Darum ddddd
    Const C_FILTER_DATE_FORMAT = "ddddd HH:mm am/pm"
        
    'Appointments auslesen
    Set ns = otl.GetNamespace("MAPI")
    Set cal = ns.GetDefaultFolder(olFolderCalendar) 'Kalender auswählen
    Set apps = cal.itemS
    
    'Sicherstellen, dass bei Serien die einzelnen Einträge übernommen werden
    'https://msdn.microsoft.com/de-de/library/office/ff866969.aspx
    apps.Sort "Start"
    apps.IncludeRecurrences = True
    
    'Filter erstellen
    'Filter-Argumente: https://msdn.microsoft.com/en-us/library/office/ff869597.aspx
    filter = "[Start] >= '" & format(iFromDate, C_FILTER_DATE_FORMAT) & "' AND [Start] <= '" & format(iToDate, C_FILTER_DATE_FORMAT) & "'"
    
    'Die Appointments filtern und ausgeben
    For Each app In apps.Restrict(filter)
        Debug.Print app.start, app.Subject
    Next app

End Sub
 
Zurück