Récupérer les RDV d'un autre calendrier OUTLOOK en VBA
p
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