Récupérer les RDV d'un autre calendrier OUTLOOK en VBA

Bonjour à tous,

Je fais appel à vous car je sais que j'ai toujours trouvé l'aide que je voulais avec vous.

Mon problème est le suivant.

Je dois faire un programme VBA qui récupère les infos de divers RDVs se trouvant sur divers calendriers partagés OUTLOOK et les mettre dans un sous formulaire Access.

Pour le moment j'ai réussi à le faire sur mon propre calendrier mais je n'arrive pas à avoir accès aux calendriers de mes collègues.

Qui aurait la solution de ce problème merci d'avance

mon Code :

Dim Date_Donnee, Date_Jour, Heure_Donnee, Heure_Deb, Min_Deb, Heure_Fin, Min_Fin As String
Dim ID_Fct, ID_TAct, texte As String
Dim datejour As Date
Dim Salarie As Variant
Dim Nbr_RDV As Integer

Dim OlApp As New Outlook.Application
Dim OlMapi As Outlook.Namespace
Dim OlFolder As Outlook.MAPIFolder
Dim OlItems As Outlook.Items
Dim OlAppointment As Outlook.AppointmentItem
Dim OlList As AddressList

Dim dbs As Database
Dim rs As Recordset
Dim qdReq As QueryDef

Set dbs = CurrentDb
Set OlMapi = OlApp.GetNamespace("MAPI")
Set OlFolder = OlMapi.GetDefaultFolder(olFolderCalendar)
'Set OlFolder = OlFolder.Folders("Veronica *****") <= c'est un des calendriers à consulter
Set OlItems = OlFolder.Items

Nbr_Salarie = OlMapi.AddressLists.Item(3).AddressEntries.Count

For Each OlAppointment In OlItems

'chargement du RDV
OlAppointment.Display

With OlAppointment

'Récupération de la date de prospection
datejour = Date - 7

'Récupération de la date du 1er RDV
Date_Donnee = .Start
Date_Jour = Left(Date_Donnee, 11)

'Si la date de prospection est egale à la date du 1er RDV alors
If datejour = Date_Jour Then

'récupération des heures du début
Heure_Donnee = Mid(Date_Donnee, 12)
Heure_Deb = Left(Heure_Donnee, 2)

'Ouverture du sous formulaire F041_Element_Salarie_Prod
DoCmd.OpenForm "F041_Element_Salarie_Prod Sous-formulaire"

'Code du dosier
Code_Dossier_Saisi = .Subject
' Création de la requete
Set qdReq = CurrentDb.CreateQueryDef("", "SELECT * FROM T01_Dossier WHERE T01_Dossier.Code_Dossier LIKE '" & Code_Dossier_Saisi & "';")
Set rs = qdReq.OpenRecordset

' Le Code dossier existe ?
If rs.BOF And rs.EOF Then
MsgBox "le code dossier a été mal saisi", vbOKOnly, "Attention"
texte = Code_Dossier_Saisi & " " & datejour & " " & Heure_Deb & " " & Heure_Fin
Fichier_Word (texte)
GoTo suite
Else:
'Mettre le code de dossier saisi dans le champ "Code_Dossier_Saisi"
Forms("F041_Element_Salarie_Prod Sous-formulaire").Controls("Code_Dossier_Saisi").Value = .Subject

'Mettre le code de dossier saisi dans le champ " Code_Dossier"
Forms("F041_Element_Salarie_Prod Sous-formulaire").Controls("Code_Dossier").Value = Code_Dossier_Saisi

End If

Forms("F041_Element_Salarie_Prod Sous-formulaire").Recordset.AddNew

Else: GoTo fin
End If
suite:

End With

Next OlAppointment

fin:

Set OlMapi = Nothing
Set OlFolder = Nothing
Set OlItems = Nothing
Set OlList = Nothing

End Sub