Outlook agenda in excel importeren MET terugkerende afspraken

Status
Niet open voor verdere reacties.

cello249

Gebruiker
Lid geworden
1 jul 2009
Berichten
14
Hoi,

Ik heb een stuk code waarmee ik de agenda-items uit outlook (2016) kan importeren in Excel.
Dat werkt prima op 1 onderdeel na.
Terugkerende afspraken worden alleen meegenomen:
1) Als de startdatum is gelegen in de opgevraagde periode
2) dan wordt hij maar 1x vermeldt en dus niet, als de afspraak dagelijks is, elke dag opnieuw in een regel vermeld

Ik heb allerlei mogelijkheden geprobeerd met recurring.items maar het lukt mij niet om voor elkaar te krijgen dat alle agenda items ook zichtbaar worden in excel.

De code is
Code:
Option Explicit

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date
    
    FromDate = CDate("02/25/2019")
    ToDate = CDate("05/30/2019")

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
    NextRow = 2

    With Sheets("Gegevens") 'Change the name of the sheet here
        .Range("A1:D1").Value = Array("Project", "Date", "Time spent", "Location")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
            If olApt.Location <> "Nederland" Then                           'als Nederlandse feestdag dan overslaan
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                .Cells(NextRow, "D").Value = olApt.Location
                .Cells(NextRow, "E").Value = olApt.Categories
                NextRow = NextRow + 1
            Else
            End If
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

Kunnen jullie mij op weg helpen?

Alvast bedankt.
 

Bijlagen

Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan