VBA Excel import appointment des calendriers partagés outlook

Encore un petit problème, lors de l'utilisation de la macro sur certain PV, j'ai une erreur d'automation :

A priori l'erreur se situe

Set calendrier = calendrier_navigation.Folder

est-il possible de mettre des bordures sur le tableau et de mettre un fond gris sur les données de la date du jour ?

Le plus simple est d'utiliser un tableau structuré qui donnera un style

Sub lister_rdvs()
    'Constantes Outlook
    Const olCalendarModule = 159
    Const olFolderInbox As Byte = 6
    Const olMinimized As Byte = 1
    Const olNonMeeting As Byte = 0
    Const olMeetingCanceled As Byte = 5

    'Variables
    Dim OLApp As Object, OLExp As Object
    Dim module As Object
    Dim module_calendrier As Object
    Dim groupe_calendriers As Object
    Dim calendrier_navigation As Object
    Dim calendrier As Object
    Dim filtre As String, ref_calendrier As String
    Dim rdvts_trouvés As Object, olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date, ToDate As Date
    Dim tb(): tb = Array("")
    Dim ligne As ListRow
    Dim Date_rdvt As Date

    '// assignation application Outlook et explorateur
    Set OLApp = CreateObject("Outlook.Application")

    ' si OutLook n'est pas ouvert .....................
    If OLApp.Explorers.Count = 0 Then
        OLApp.Session.GetDefaultFolder(olFolderInbox).Display
        OLApp.ActiveExplorer.WindowState = olMinimized
    End If
    ' .....................................................
    Set OLExp = OLApp.ActiveExplorer

    '// assignation fourchette de dates
    FromDate = CDate(InputBox("Date de début (format: dd/mm/yyyy)"))
    ToDate = CDate(InputBox("Date de fin(format: dd/mm/yyyy)"))

    '// initialisation feuille "Calend"
    With ThisWorkbook.Sheets("calend")
        .Cells.ClearContents
        .Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")
        .Columns("B:C").NumberFormat = "m/d/yyyy"
        .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = "Rendez_vous"
    End With

    '// exploration des calendriers
    For Each module In OLExp.NavigationPane.Modules

        If module.Class = olCalendarModule Then
            For Each groupe_calendriers In module.NavigationGroups

                For Each calendrier_navigation In groupe_calendriers.NavigationFolders
                    'assignation du calendrier
                    Set calendrier = calendrier_navigation.folder
                    'stockage rdvs du calendrier
                    GoSub Stockage_rdvts
                Next calendrier_navigation

            Next groupe_calendriers
            Exit For
        End If

    Next module

    '// remplissage de la feuille à partir des rdvs stockés
    With [Rendez_vous].ListObject

        'remplissage feuille
        If UBound(tb) > -1 Then
            .Range.Offset(1).Resize(UBound(tb) + 1).Value = Application.Index(tb, 0, 0)
            .Range.Columns.AutoFit
        End If

        'reconnaissance dates de début et de fin
        For Each ligne In .ListRows
            ligne.Range(2) = CDate(ligne.Range(2))
            ligne.Range(3) = CDate(ligne.Range(3))
        Next ligne

        'tri sur date début
        .Range.Sort key1:=.ListColumns("Début"), order1:=xlAscending, Header:=xlYes
    End With

    '// sortie procédure
    Exit Sub

'// sous_procédure de stockage des rdvts dans un tableau selon filtre de dates
Stockage_rdvts:
    'filtrage des rdvs correspondant à la fourchette de dates
    filtre = "[Start] > '" & FromDate & "'" & "And" & "[Start] < '" & ToDate + 1 & "'"
    Set rdvts_trouvés = calendrier.Items.Restrict(filtre)
    rdvts_trouvés.Sort "[Start]"

    'analyse des rdvts trouvés
    For Each olApt In rdvts_trouvés
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
            If Not olApt.IsRecurring Then
                If olApt.MeetingStatus <> olMeetingCanceled Then
                    ReDim Preserve tb(NextRow)
                    ref_calendrier = calendrier_navigation.DisplayName
                    tb(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, ref_calendrier)
                    NextRow = NextRow + 1
                End If
            Else
                Date_rdvt = DateSerial(Year(Date), olApt.GetRecurrencePattern.MonthOfYear, olApt.GetRecurrencePattern.DayOfMonth)
                If Date_rdvt >= FromDate And Date_rdvt <= ToDate _
                And olApt.MeetingStatus <> olMeetingCanceled Then
                    ReDim Preserve tb(NextRow)
                    ref_calendrier = calendrier_navigation.DisplayName
                    tb(NextRow) = Array(olApt.Subject, Date_rdvt, olApt.GetRecurrencePattern.PatternEndDate, olApt.Location, ref_calendrier)
                    NextRow = NextRow + 1
                End If
            End If
        End If
    Next olApt

    Return

End Sub

est-il possible de mettre des bordures sur le tableau et de mettre un fond gris sur les données de la date du jour ?

Merci, mais la macro met une ligne sur deux en bleu.

Encore un petit problème, lors de l'utilisation de la macro sur certain PV, j'ai une erreur d'automation :

automation

A priori l'erreur se situe

Set calendrier = calendrier_navigation.Folder

Pourquoi ces erreurs sur certain PC, alors que les versions d'excel sont les mêmes

Merci à vous

Encore un petit problème, lors de l'utilisation de la macro sur certain PV, j'ai une erreur d'automation :

automation

A priori l'erreur se situe

Set calendrier = calendrier_navigation.Folder

Pourquoi ces erreurs sur certain PC, alors que les versions d'excel sont les mêmes

Je suppose que le calendrier n'est pas disponible sur leur poste. Il faut donc gérer l'erreur comme ceci :

        
        If module.Class = olCalendarModule Then
            For Each groupe_calendriers In module.NavigationGroups

                For Each calendrier_navigation In groupe_calendriers.NavigationFolders
                    On Error Resume Next

                    'assignation du calendrier
                    Set calendrier = calendrier_navigation.folder

                    'stockage rdvs du calendrier
                    If Err = 0 Then GoSub Stockage_rdvts

                    On Error GoTo 0
                Next calendrier_navigation

            Next groupe_calendriers
            Exit For
        End If

Merci, mais la macro met une ligne sur deux en bleu.

Vous pouvez parfaitement changer le style du tableau structuré. Exemple de style gris (style moyen 4)

    
    '// initialisation feuille "Calend"
    With ThisWorkbook.Sheets("calend")
        .Cells.ClearContents
        .Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")
        .Columns("B:C").NumberFormat = "m/d/yyyy"
        .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes, , "TableStyleMedium4").Name = "Rendez_vous"
    End With

Je suppose que le calendrier n'est pas disponible sur leur poste. Il faut donc gérer l'erreur comme ceci :

Merci à vous, mais j'ai une erreur incompatibilité de type 13, et le debogage s'arrête ici :

Then .Range("A2").Resize(UBound(tb) + 1, 5).Value = Application.Index(tb, 0, 0) _
        Else

En fait tout fonctionne, j'ai juste repartagé les calendriers de manière idoine pour les PC concernés.

Une question en amenant une autre, est-il possible de ne pas faire apparaître les rendez-vous privés ?

Merci à vous.

est-il possible de ne pas faire apparaître les rendez-vous privés ?

ci-dessous ajouts dans code :

Sub lister_rdvs()
    'Constantes Outlook
    Const olCalendarModule = 159
    Const olFolderInbox As Byte = 6
    Const olMinimized As Byte = 1
    Const olNonMeeting As Byte = 0
    Const olMeetingCanceled As Byte = 5
    Const olPrivate As Byte = 2

'..........................................

    'analyse des rdvts trouvés
    For Each olApt In rdvts_trouvés
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") And olApt.Sensitivity <> olPrivate Then
            If Not olApt.IsRecurring Then

'............

Bonjour,

Je vous remercie pour toutes les solutions que vous m'avez apporté.

Tout fonctionne correctement.

Je vous souhaite une excellente journée.