Outlook - Kalender im Code ändern

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") = 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)) = startDate And  _
DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) 

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 

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  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