@Olli: Kalenderdaten einlesen
02.10.2004 17:23:19
Ramses
von hinten durch die Brust ins Auge :-)
Ohne jeweils alle Kalendereinträge zu durchforsten, lässt sich das Problem des richtigen Einlesens von Kalenderdaten meines Erwachtens nach nicht lösen.
Das Hauptproblem liegt in der Outlook internen Verwaltung der Serientermine.
Wenn jemand noch eine andere Idee hat, bin ich natürlich immer offen :-)
Mit dem Code läuft es jetzt auf jeden Fall:
Option Explicit
Sub Kalenderdaten_auf_Terminbereich_einlesen()
'(C) Ramses
'Zunächst Verweis auf OL-Bibliothek erstellen
'Early Binding ab Outlook 2003 nicht möglich
'weil die Rückgabewerte der ITEM-Indexes zufällig ist und von der
'Installation abhängt !!
'Version Office 2000 (nicht getestet sollte aber tun)
'Dim olApp As Outlook.Application
'Dim Termin As Outlook.AppointmentItem
'Dim myTerminPatt As Outlook.RecurrencePattern
'Set olApp = New outlook.Application
'Set Termin = olApp.CreateItem(olAppointmentItem)
'Version XP
Dim olApp As Object
Dim Termin As Object
Set olApp = CreateObject("Outlook.Application")
'Allgemein gültig
Dim i As Long, j As Long, myErr As Integer
Dim startInput As String, startDate As Date
Dim endInput As String, endDate As Date
Dim myTerminPatt As Object
On Error GoTo myErrorhandler
'Erst mal alles löschen
Cells.ClearContents
Cells.Interior.ColorIndex = xlNone
'Startdatum abfragen
startInput = InputBox("Bitte Datum eingeben im Format ""01.01.2004""", "Datum für Terminsuche", Format(Now, "dd.mm.yyyy"))
myErr = 1
If startInput = "" Then
MsgBox "Abbruch des Makros durch Benutzer"
Exit Sub
ElseIf Not IsDate(DateValue(startInput)) Then
MsgBox "Falsches Datum eingegeben"
Exit Sub
End If
myErr = 2
endInput = InputBox("Bitte Datum eingeben im Format ""01.01.2004""", "Datum für Terminsuche", Format(DateValue(startInput) + 7, "dd.mm.yyyy"))
If endInput = "" Then
MsgBox "Abbruch des Makros durch Benutzer"
Exit Sub
ElseIf Not IsDate(DateValue(endInput)) Then
MsgBox "Falsches Datum eingegeben"
Exit Sub
End If
myErr = 0
'Variable definitiv zuweisen
startDate = DateValue(startInput)
endDate = DateValue(endInput)
'Variable fü¨r Termin neu setzen
'Set Termin = olApp.CreateItem(Appointment)
Cells(1, 1) = "Termine vom " & Format(startDate, "dd.mm.yyyy") & " bis " & Format(endDate, "dd.mm.yyyy")
i = 3
Application.ScreenUpdating = False
Cells(i, 1) = "Termin Betreff"
Cells(i, 2) = "Inhalt/Body"
Cells(i, 3) = "Start"
Cells(i, 4) = "Ende"
Cells(i, 5) = "Erinnerung Minuten"
Cells(i, 6) = "Anzeigen als"
Cells(i, 7) = "Kategorien"
Cells(i, 8) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 8)).Select
Selection.Interior.ColorIndex = 15
'Durchlaufe alle Termine des aktuellen Standardkalenders
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
Set myTerminPatt = Termin.GetRecurrencePattern
If Format(Termin.Start, "dd.mm.yyyy") >= startDate And Format(Termin.End, "dd.mm.yyyy") <= endDate Then
If Not Termin.AllDayEvent Then Trag_ein Termin, i, False
End If
If myTerminPatt.RecurrenceType = olRecursDaily Then
If Format(myTerminPatt.PatternEndDate, "dd.mm.yyyy") >= startDate Then
Trag_ein_Recurr Termin, i, False, startDate, endDate
End If
End If
Next
Range("C1").Select
Range("A1:H" & Range("A1").CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
'Jetzt die Ereignisse
i = i + 1
j = i
Cells(i, 1) = "Ganzer Tag Betreff"
Cells(i, 2) = "Ereignis am"
Cells(i, 3) = "Erinnerung Minuten"
Cells(i, 4) = "Anzeigen als"
Cells(i, 5) = "Kategorien"
Cells(i, 6) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 6)).Select
Selection.Interior.ColorIndex = 15
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
Debug.Print Termin.Start
If DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) >= startDate And DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) <= endDate Then
If Termin.AllDayEvent And Not Termin.IsRecurring Then Trag_ein Termin, i, True
End If
Next
Range("C" & j).Select
Range("A1:F" & Range("A" & j).CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
'und noch die jährlichen Ereignisse
i = i + 2
j = i
Cells(i, 1) = "Betreff ""Jährliches Ereignis"""
Cells(i, 2) = "jährliches Ereignis am"
Cells(i, 3) = "Erinnerung Minuten"
Cells(i, 4) = "Anzeigen als"
Cells(i, 5) = "Kategorien"
Cells(i, 6) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 6)).Select
Selection.Interior.ColorIndex = 15
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
If DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) >= startDate And DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) <= endDate Then
If Termin.AllDayEvent And Termin.IsRecurring Then Trag_ein Termin, i, True
End If
Next
Range("C" & j).Select
Range("A1:F" & Range("A" & j).CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
'Variablen leeren
Set Termin = Nothing
Set olApp = Nothing
Columns("A:H").Select
Columns("A:H").EntireColumn.AutoFit
Range("A1").Select
Cells.RowHeight = "12.75"
'Ausstieg
ErrorExit:
Application.ScreenUpdating = True
If myErr = 0 And Err.Number = 0 Then
MsgBox "Kalenderdaten eingelesen"
End If
Exit Sub
myErrorhandler:
Select Case myErr
Case 1
MsgBox "Ungültiges Startdatum"
Resume ErrorExit
Case 2
MsgBox "Ungültiges Enddatum"
Resume ErrorExit
End Select
MsgBox Err.Number & " " & Err.Description
Resume ErrorExit
End Sub
Sub Trag_ein(Termin, i As Long, Ereignis As Boolean)
Dim Anzeigen_als As String
Dim Erinnerung As String
Select Case Termin.BusyStatus
Case olFree
Anzeigen_als = "Frei"
Case olTentative
Anzeigen_als = "Unter Vorbehalt"
Case olBusy
Anzeigen_als = "Gebucht"
Case olOutOfOffice
Anzeigen_als = "Abwesend"
End Select
Cells(i, 1) = Termin.Subject
If Not Ereignis Then
Cells(i, 2) = Termin.Body
Cells(i, 3) = Termin.Start
Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 4) = Termin.End
Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 5) = Termin.ReminderMinutesBeforeStart
Cells(i, 6) = Anzeigen_als
Cells(i, 7) = Termin.Categories
Cells(i, 8) = Termin.CreationTime
Else
Cells(i, 2) = Termin.Start
Cells(i, 2).NumberFormat = "dd/mm/yyyy hh:mm"
If Termin.ReminderMinutesBeforeStart <= 60 Then
Erinnerung = Termin.ReminderMinutesBeforeStart & " Minuten"
ElseIf Termin.ReminderMinutesBeforeStart / 60 < 24 Then
Erinnerung = Termin.ReminderMinutesBeforeStart / 60 & " Stunden"
Else
Erinnerung = Termin.ReminderMinutesBeforeStart / 60 / 24 & " Tage"
End If
Cells(i, 3) = Erinnerung
Cells(i, 3).NumberFormat = "General"
Cells(i, 4) = Anzeigen_als
Cells(i, 5) = Termin.Categories
Cells(i, 6) = Termin.CreationTime
End If
i = i + 1
End Sub
Sub Trag_ein_Recurr(Termin, i As Long, Ereignis As Boolean, startDate As Date, endDate As Date)
Dim Anzeigen_als As String
Dim Erinnerung As String
Dim n As Integer
Dim myReccTermin As Object
Select Case Termin.BusyStatus
Case olFree
Anzeigen_als = "Frei"
Case olTentative
Anzeigen_als = "Unter Vorbehalt"
Case olBusy
Anzeigen_als = "Gebucht"
Case olOutOfOffice
Anzeigen_als = "Abwesend"
End Select
Set myReccTermin = Termin.GetRecurrencePattern
If startDate = endDate Then
Cells(i, 1) = Termin.Subject
Cells(i, 3) = startDate + (i - 1)
Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 4) = startDate + (i - 1)
Cells(i, 4).Interior.ColorIndex = 3
Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 5) = Termin.ReminderMinutesBeforeStart
Cells(i, 6) = Anzeigen_als
Cells(i, 7) = Termin.Categories
Cells(i, 8) = Termin.CreationTime
i = i + 1
Set myReccTermin = Nothing
Exit Sub
End If
If myReccTermin.PatternEndDate < endDate Then
Debug.Print myReccTermin.PatternEndDate
If myReccTermin.PatternStartDate > startDate Then
For n = 1 To endDate - myReccTermin.PatternEndDate '(myReccTermin.PatternStartDate - startDate)
Cells(i, 1) = Termin.Subject
Cells(i, 3) = myReccTermin.PatternStartDate + n
Cells(i, 3).Interior.ColorIndex = 3
Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 4) = myReccTermin.PatternStartDate + n
Cells(i, 4).Interior.ColorIndex = 3
Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 5) = Termin.ReminderMinutesBeforeStart
Cells(i, 6) = Anzeigen_als
Select Case myReccTermin.RecurrenceType
Case 1
Cells(i, 7) = "Täglich"
Case 2, 3
Cells(i, 7) = "Monatlich"
Case 4
Cells(i, 7) = "Wöchentlich"
Case 5, 6
Cells(i, 7) = "Jährlich"
Case Else
Cells(i, 7) = "Serie"
End Select
Cells(i, 8) = Termin.CreationTime
i = i + 1
Next n
Else
For n = 1 To myReccTermin.PatternEndDate - startDate
Cells(i, 1) = Termin.Subject
Cells(i, 3) = startDate + n
Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 4) = startDate + n
Cells(i, 4).Interior.ColorIndex = 3
Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 5) = Termin.ReminderMinutesBeforeStart
Cells(i, 6) = Anzeigen_als
Select Case myReccTermin.RecurrenceType
Case 1
Cells(i, 7) = "Täglich"
Case 2, 3
Cells(i, 7) = "Monatlich"
Case 4
Cells(i, 7) = "Wöchentlich"
Case 5, 6
Cells(i, 7) = "Jährlich"
Case Else
Cells(i, 7) = "Serie"
End Select
Cells(i, 8) = Termin.CreationTime
i = i + 1
Next n
End If
End If
If myReccTermin.PatternEndDate > endDate Then
If myReccTermin.PatternStartDate > startDate Then
For n = 1 To endDate - myReccTermin.PatternStartDate
Cells(i, 1) = Termin.Subject
Cells(i, 3) = myReccTermin.PatternStartDate + n
Cells(i, 3).Interior.ColorIndex = 3
Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 4) = myReccTermin.PatternStartDate + n
Cells(i, 4).Interior.ColorIndex = 3
Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 5) = Termin.ReminderMinutesBeforeStart
Cells(i, 6) = Anzeigen_als
Select Case myReccTermin.RecurrenceType
Case 1
Cells(i, 7) = "Täglich"
Case 2, 3
Cells(i, 7) = "Monatlich"
Case 4
Cells(i, 7) = "Wöchentlich"
Case 5, 6
Cells(i, 7) = "Jährlich"
Case Else
Cells(i, 7) = "Serie"
End Select
Cells(i, 8) = Termin.CreationTime
i = i + 1
Next n
Else
For n = 1 To myReccTermin.PatternEndDate - startDate
Cells(i, 1) = Termin.Subject
Cells(i, 3) = startDate + n
Cells(i, 3).Interior.ColorIndex = 3
Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 4) = startDate + n
Cells(i, 4).Interior.ColorIndex = 3
Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 5) = Termin.ReminderMinutesBeforeStart
Cells(i, 6) = Anzeigen_als
Select Case myReccTermin.RecurrenceType
Case 1
Cells(i, 7) = "Täglich"
Case 2, 3
Cells(i, 7) = "Monatlich"
Case 4
Cells(i, 7) = "Wöchentlich"
Case 5, 6
Cells(i, 7) = "Jährlich"
Case Else
Cells(i, 7) = "Serie"
End Select
Cells(i, 8) = Termin.CreationTime
i = i + 1
Next n
End If
End If
Set myReccTermin = Nothing
End Sub
Dabei erhältst du diese Tabelle als Ergebnis
| Tabelle1 | ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
| ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Achte hier mal auf das Erstellungsdatum des jährlichen Ereignisses:
Das ist das Startdatum !!! und kann mit der Restrict-Methode, die natürlich schneller wäre, nicht abgefangen wäre.
Viel Spass beim ausprobieren :-)
Aber vorerst ist jetzt erst mal Schluss :-)
Gruss Rainer