Option Explicit
Sub BoucleSousDossiersCalendrier()
'nécessite d'activer la référence
'Microsoft Outlook xx.xx Object Library
Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Dossier As MAPIFolder, SousDos As MAPIFolder
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
'Indique le calendrier définit par défaut
Set Dossier = olNs.GetDefaultFolder(olFolderCalendar)
ExtractionCalendrier Dossier
'Boucles sur les sous dossiers
For Each SousDos In Dossier.Folders
ExtractionCalendrier SousDos
Next SousDos
Set Dossier = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Sub ExtractionCalendrier(Rep As MAPIFolder)
Dim olRdv As AppointmentItem
'Boucle sur les éléments du répertoire
For Each olRdv In Rep.Items
'Affichage dans la fenêtre d'exécution : CTRL+G
Debug.Print Rep.Name & "/ " & olRdv.Subject & " / " & olRdv.Start
Next olRdv
End Sub