[VBA] Modification / suppression de rendez-vous dans calendrier partagé Outlook

Question

Bonjour à tous !

Puisque j'ai un truc qui m'embête depuis deux jours, j'ai décidé de vous embêter avec aussi ... Mais vu mon level de newbie autodidacte face au level des vétérans du forum, si ça se trouve ce sera de la gnognotte pour vous... 


Exposition de mon projet :

J'ai créé une BDD Access pour mon équipe. Cette BDD doit être capable via VBA de créer des rendez-vous à partager avec les membres de l'équipe. Pour cela, j'ai créé un calendrier spécifique et l'ai partagé en donnant les droits éditeur aux autres. Pour info, nos comptes mail sont connectés à un serveur Exchange. Sur VBA, j'ai réussi à créer un rendez-vous avec un de mes collègues en destinataire.


Résultat :

Manuellement dans Outlook, le destinataire réussit à modifier le rendez-vous. Par contre, dès qu'il essaie de modifier via la BDD (via VBA), là, ça plante : 'runtime error -2147221233 (8004010f) operation failed' 
Par contre, depuis mon compte, j'arrive à faire toutes les opérations via VBA, càd créer un rendez-vous, le modifier et le supprimer.


Le code, maintenant, enregistré dans une sub de la base Access :

J'utilise la fonction GetSharedDefaultFolder.


Set ol = New outlook.Application
Set olns = ol.GetNamespace("MAPI")
Set myRecipient = olns.CreateRecipient("Morback Tartenpion")
myRecipient.Resolve
If myRecipient.Resolved Then
   Set myFolder = olns.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
End If
Set mysubFolder = myFolder.Folders("Calendrier_partagé").Items
trouvé = 0
mysubFolder.Sort "[Subject]"
Set rst CurrentDb.OpenRecordset("SELECT T_client.nom_client FROM T_client WHERE T_client.ID_client " & CStr(Forms("F_enr_projet").ID_client.Value))
Set appt mysubFolder.Find("[Subject] '" & CStr(rst!nom_client) & " / " & CStr(Forms("F_enr_projet").description_projet.Value) & " / " & CStr(désignation_action.Value) & "'")
While TypeName(appt) <> "Nothing"
    trouvé = 1
    appt.Start = CStr(date_prévisionnelle.Value) & " 09:00"
    If Not IsNull(commentaire.Value) Then
        appt.Body = CStr(commentaire.Value)
    Else
        appt.Body = ""
    End If
    Set rst CurrentDb.OpenRecordset("SELECT T_acteur.mail_acteur FROM T_acteur WHERE T_acteur.ID_acteur " & CStr(Forms("F_enr_action").ID_acteur))
    appt.Recipients.Add CStr(rst!mail_acteur)
    appt.Save
    appt.Send
    Set appt = mysubFolder.FindNext
    MsgBox ("Rendez-vous modifié")
Wend
If trouvé = 0 Then
    objOutlookMeet = mysubFolder.Add
    'et blablabla, et blablabla.
Endif



Chez mes collègues, le code ne va pas très loin, puisque qu'il s'arrète à :
Set myFolder = olns.GetSharedDefaultFolder(myRecipient, olFolderCalendar)

Je ne vois pas ce que j'ai loupé . Chers as des as, help, please heeeeelp ! 

Morback

acive · Answer

Bonjour,

Bon, je ne peux pas le tester mais j'ai vu CETTE DISCUTION

Ça pourrait t'inspirer... (regarde jusqu'à la fin) 


Cordialement


CF2i - Guadeloupe
Ingénierie Informatique

morback · Answer

Merci Acive pour ta recherche.

Je vais chercher de ce côté, du coup aussi. Ca donne une piste supplémentaire. Le souci avec la méthode utilisant :
strFolder = "Public Folders - " & olns.DefaultStore.DisplayName
c'est qu'il faut avoir créé un dossier public dans lequel le calendrier partagé serait rangé. Et le problème, c'est que je n'ai pas les droits pour créer un tel dossier. Je reboucle avec mon admin, voir ce qu'il est possible de faire.

Mais je pense qu'il y a une autre méthode sans avoir à créer quoi que ce soit d'autre, étant donné qu'on arrive à modifier les rendez-vous manuellement.

Allez, je replonge.

Morback

morback · Answer

Ayééé ! J'ai trouvé qqch qui marche !

Du coup, je vous donne plus de code, c'est pour la modif d'un rendez-vous d'un calendrier partagé s'il existe déjà, sinon création du rendez-vous dans le calendrier partagé.



Dim ol As outlook.Application
Dim olns As outlook.NameSpace
Dim myRecipient As outlook.Recipient
Dim myFolder As outlook.Folder
Dim objExpCal As outlook.Explorer
Dim objNavMod As outlook.CalendarModule
Dim objNavGroup As outlook.NavigationGroup
Dim objNavFolder As outlook.NavigationFolder
Dim objAppt As AppointmentItem

Set ol = New outlook.Application
Set olns = ol.Session
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = ol.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "Boîte aux lettres - nom_du_propriétaire_du_calendrier_partagé" Then
'cas où le propriétaire du calendrier partagé fait l'opération
    Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
    Set mysubfolder = myFolder.Folders("nom_du_calendrier_partagé").Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
    Set myRecipient = olns.CreateRecipient("nom_du_propriétaire_du_calendrier_partagé")
        myRecipient.Resolve
    If myRecipient.Resolved Then
       Set mysubfolder = objNavGroup.NavigationFolders("nom_du_propriétaire_du_calendrier_partagé - nom_du_calendrier_partagé").Folder.Items
    End If
End If
'vérification de l'existance du rendez-vous en comparant le sujet du RDV
trouvé = 0
mysubfolder.Sort "[Subject]"
Set objAppt mysubfolder.Find("[Subject] '" & "nom_du_sujet & "'")
While TypeName(objAppt) <> "Nothing"
'parcourt de tous les RDV du calendrier et modification des RDV ayant le sujet recherché
    trouvé = 1
    objAppt.Start = "date prévue" & " 09:00"
    objAppt.Body = "commentaire"
    objAppt.Recipients.Add "nom_du_destinataire"
    objAppt.Save
    objAppt.Send
    Set objAppt = mysubfolder.FindNext
    MsgBox ("Rendez-vous modifié")
Wend
If trouvé = 0 Then
'cas où le sujet n'existe pas dans le calendrier, création de celui-ci
    Set objAppt = mysubfolder.Add
    PCalendrier = ""
    PDate = CStr(date_prévisionnelle.Value)
    PHeure = "09:00"
    PDuree = 60
    PSubject = "nom_du_sujet"
    PDestinataire = "nom_du_destinataire"
    PNotes = "notes"
    PLieu = "N/A"
    PMinutesRappel = 60
    With objAppt
        .MeetingStatus = olMeeting
        If PDuree > 0 Then
            .Start = PDate & " " & PHeure
            .Duration = PDuree
        Else
            .Start = PDate
            .AllDayEvent = True
        End If
        .Subject = PSubject
        .Recipients.Add (PDestinataire)
        .Body = PNotes
        .Location = PLieu
        'Ajoute le rappel
        If PMinutesRappel > 0 Then
            .ReminderMinutesBeforeStart = PMinutesRappel
            .ReminderSet = True
        End If
        'Sauvegarde et ferme
        .Recipients.ResolveAll
        .Save
        .Send
        MsgBox "Rdv ajouté!"
    End With
End If


Si quelqu'un voit qqch de pas très orthodoxe (ou catholique, ou autre chose d'ailleurs), je suis tout ouïe.
Par contre, je comprends toujours pas pourquoi GetSharedDefaultFolder marche pas...

Bon allez, on est vendredi, ça mérite une p'tite mousse ! (à consommer s..avec modération, bien sûr )

Morback

acive · Answer

Salut Morbak,
C'est très bien que tu aies posté le code car il n'y a pas grand-chose sur le web concernant l'erreur "runtime error -2147221233 (8004010f)" j'ai cru voir que c'est un problème de conflit de versions mais c'est tout.

Merci à toi 

Cordialement


CF2i - Guadeloupe
Ingénierie Informatique

[VBA] Modification / suppression de rendez-vous dans calendrier partagé Outlook

4 réponses

Votre réponse

Discussions similaires