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