Outlook Kalender Makro

Sub ReadCalendarItems(Betreff As String)
Dim objApp As Outlook.Application
Dim objNS As Namespace
Dim objCalendar As MAPIFolder
Dim objItem As AppointmentItem
Dim strSubject As String
Dim ObjRecipient As Recipient
Dim i As Long
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objCalendar = objNS.GetDefaultFolder(olFolderCalendar)
i = 1
'Leere Blatt
Application.EnableEvents = False
Range("A4:Z4,A6:Z6,A8:Z8,A10:Z10").ClearContents
Application.EnableEvents = True
For Each objItem In objCalendar.Items
With objItem
If InStr(1, LCase(.Subject), LCase(Betreff))  0 Then
Application.EnableEvents = False
If InStr(1, .Start, " ")  0 Then
If Left(.Start, InStr(1, .Start, " ") - 1) = Left(.End, InStr(1, .Start, " ") - 1) Then
'Resultat in Zellen schreiben
Cells(4, i).Value = Left(.Start, InStr(1, .Start, " ") - 1)
Else
Cells(4, i).Value = Left(.Start, InStr(1, .Start, " ") - 1) & " - " & Left(.End, InStr(1, .Start, " ") - 1)
End If
Cells(6, i).Value = Mid(.Start, InStr(1, .Start, " ") + 1) & " - " & Mid(.End, InStr(1, .Start, " ") + 1)
Else
Cells(4, i).Value = .Start
End If
Cells(8, i).Value = .Subject
'Spalte formatieren
With Columns(i)
.ColumnWidth = 40
.Cells.Rows.AutoFit
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlTop
End With
i = i + 1
Application.EnableEvents = True
End If
'   If .Recipients.Count > 0 Then
'     For Each ObjRecipient In .Recipients
'       Debug.Print ObjRecipient.Name & " / "  ' & ObjRecipient.Address
'     Next
'   End If
'End If
End With
Next
If i = 1 Then
MsgBox "Keine Eintraege gefunden", 16
Else
MsgBox "Kalender durchsucht.", 64
End If
End Sub