Ich möchte aus freigegeben Outlook Kalendern Termine extrahieren und auflisten.
Aus Internetrescherchen habe ich folgende Code zusammengebastelt:
Sub FindTermine()
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olNS As Outlook.NameSpace: Set olNS = olApp.GetNamespace("MAPI")
Dim olApt As Object
Dim NextRow As Long
Dim FromDate As Date
Dim ToDate As Date
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Import")
Dim myAppointments As Outlook.Items
Dim objOwner As Object: Set objOwner = olNS.CreateRecipient(AvailableCals.Value)
FromDate = CDate(MonBox.Value)
ToDate = CDate(EndDate.Caption)
On Error Resume Next
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
objOwner.Resolve
If objOwner.Resolved Then
Set myAppointments = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar).Items
End If
myAppointments.Sort "[Start]"
myAppointments.IncludeRecurrences = True
Set olApt = myAppointments.Find("[Start] >= """ & _
FromDate & """ and [Start] <= """ & ToDate & """")
'###################################################
While TypeName(olApt) <> "Nothing"
MsgBox objOwner & " - " & olApt.Subject & " - " & CDate(olApt.Start) & " - " & CDate(olApt.End) _
_
& " - " & Format(olApt.End - olApt.Start, "0.00") & " - " & olApt.Location
Set olApt = myAppointments.FindNext
Wend
End Sub
(Die "objOwner" und die "FromDate" und "ToDate" werden über ein Formular gespeist)
Dies funktioniert auch super. Allerdings, möchte ich die Daten in eine tabelle auflisten und nicht in ein MsgBox.
Hierzu habe ich die untere Teil wie folgt ersetzt:
While TypeName(olApt) <> "Nothing"
NextRow = 2
With Sheets("Import")
.Range("A2:F199").Value = ""
.Range("A1:F1").Value = Array("Besitzer", "Termin", "Beginn", "Ende", "Dauer", "Ort")< _
br>
For Each olApt In myAppointments.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(NextRow, "A").Value = objOwner
.Cells(NextRow, "B").Value = olApt.Subject
.Cells(NextRow, "C").Value = CDate(olApt.Start)
.Cells(NextRow, "D").Value = CDate(olApt.End)
.Cells(NextRow, "D").NumberFormat = "HH:MM"
.Cells(NextRow, "E").Value = olApt.End - olApt.Start
.Cells(NextRow, "E").NumberFormat = "HH:MM"
.Cells(NextRow, "F").Value = olApt.Location
NextRow = NextRow + 1
Else
End If
Next olApt
On Error GoTo 0
.Columns.AutoFit
End With
Set olApt = Nothing
Set myAppointments = Nothing
Set olNS = Nothing
Set olApp = Nothing
Wend
cleanExit:
Application.ScreenUpdating = True
Exit Sub
ErrHand:
'Add error handler
Resume cleanExit
End Sub
Dies jedoch liefert nur den ersten Termin und sonst keine.
Was mache ich falsch? Kann mir jemand in die richtige Richtung schicken
|