import calendrier outlook public depuis excel en vba

Sub DLRendezVousOutlookDansExcel()
Dim MyOlSession As New OUTLOOK.Application
Dim MyNS As OUTLOOK.Namespace
Dim MyFolder As OUTLOOK.MAPIFolder
Dim olRendezVous As OUTLOOK.AppointmentItem
 
Dim wbClasseur As Workbook
Dim wsFeuille As Worksheet
Dim rgPlage As Range, rgEntete As Range
 
Dim i As Long, TabEntete() As Variant
 
On Error GoTo Erreur
    Application.ScreenUpdating = False
TabEntete = Array("Date & Heure début", "Objet", "Message")
 
Set wbClasseur = Workbooks.Add
    Set wsFeuille = wbClasseur.Sheets(1)
        Set rgEntete = wsFeuille.Range(Cells(1, 1), Cells(1, UBound(TabEntete)))
            rgEntete.Value = TabEntete
    'récup des objets appointment dans Calendar
    Set MyNS = MyOlSession.GetNamespace("MAPI")
        Set MyFolder = MyNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
             'chercher le bon répertoire : code à adapter
             Set MyFolder = MyFolder.Folders("\Agenda\Planning")
 
        For i = 1 To MyFolder.Items.Count
            Set olRendezVous = MyFolder.Items(i)
                    Cells(i + 1, 1).Value = olRendezVous.Start 'début de la réunion
                Cells(i + 1, 2).Value = olRendezVous.Subject 'Objet
            Cells(i + 1, 3).Value = olRendezVous.Body 'corps du message éventuel
        Next i
 
    Set rgPlage = wsFeuille.UsedRange
    'tri chronologique & mise en forme
        With rgPlage
            .Sort Range("A1"), xlAscending, , , , , , xlGuess
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlGeneral
            .WrapText = False
        End With
 
    Columns("A:C").EntireColumn.AutoFit
 
' désinstanciation
Set MyNS = Nothing
    Set MyFolder = Nothing
        Set olRendezVous = Nothing
            Set rgPlage = Nothing
        Set rgEntete = Nothing
    Set wsFeuille = Nothing
Set wbClasseur = Nothing
 
Application.ScreenUpdating = True
Exit Sub
 
'Gestionnaire d'erreur
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source
        Set MyNS = Nothing
            Set MyFolder = Nothing
                Set olRendezVous = Nothing
                Set rgEntete = Nothing
            Set rgPlage = Nothing
        Set wsFeuille = Nothing
    Set wbClasseur = Nothing
Application.ScreenUpdating = True
 
End Sub

Set MyFolder = MyFolder.Folders("Agenda")
Set MyFolder = MyFolder.Folders("Planning")