XL 2016 Inscrire des RDV dans Outlook (calendrier partagé) via Excel macro

Lolote83 · 5 Mai 2020

Bonjour à tous et à toutes,
Cela fait maintenant 3 jours que je parcours le Net à la recherche d'une solution.
Le sujet ne relevant pas spécifiquement d'Excel, je me suis permis de poster également sous l'intitulé Outlook sur ce même forum.
Peut être que des excelliens (nes) y parviendront. Désolé du coup pour le doublon.
De nombreuses questions ont effectivement déjà été posées mais aucune ne donne une solution acceptable.
J'essaye de créer des RDV depuis Excel sur un calendrier partagé.
- Je sais écrire sur le calendrier principal nommé "Calendrier"
- Je sais écrire sur un calendrier que j'ai partagé avec ma collègue nommé "Contrat" (mais elle ne peut pas écrire dessus)
- Ma collègue sait écrire sur un calendrier quelle a partagé avec moi nommé "TOTO" (mais je ne peux pas écrire dessus)

Ci dessous une copie d'écran qui résume ce qui est dessus
Lien supprimé
Tous les codes trouvés de droite et de gauche parlent de "calendrier partagés" mais je n'arrive pas à écrire sur "TOTO"
Vous trouverez donc dans le fichier joint,
- un onglet base qui résume ce qui est expliqué ci-dessus
- un onglet liens suivis qui montre une petite liste de liens que j'ai parcouru sur le sujet
- un module Mod_Ajout qui inscrit des RDV dans Calendrier (OK), dans Contrat (OK) mais pas dans Toto
- un module Mod_Test ou j'ai quelques tests
Je continue mes recherches mais si quelqu'un a déjà rencontré ce problème et a une solution, je suis preneur.
Par avance merci beaucoup
@+ Lolote83

zebanx · 5 Mai 2020

Bonsoir Lolote83, le forum

Je ne peux répondre à ta demande mais peut-être trouveras-tu quelques lignes de codes sur des fils externes qui peuvent aider à trouver la bonne syntaxe :

vba outlook read/write items from a non default shared calendar

social.msdn.microsoft.com

Creating an Outlook Appointment in a shared calendar

Hi all, I am trying to write a VBA to create an Outlook Appointment in a shared calendar. The below code creates an appointment, but in my own default calendar. I would appreciate any help anyone can provide, as I am struggle to find an answer. Sub CalendarEntry() Dim OutApp As Object Dim...

www.mrexcel.com

Bon courage et si ça fonctionne, pourras tu nous faire un update stp ?

Merci, bonne soirée
zebanx

Lolote83 · 5 Mai 2020

Bonsoir Zebanx.
Merci pour les liens.
Je viens de faire des essais, et rien de concluant. N'y aurait-il pas de solution ?
Je continue mes recherches malgré les 10 000 sites visités, 10 000 tests effectués.
Merci mais je ne dois tout de même pas être le seul dans ce cas !!!
@+ Lolote83

zebanx · 5 Mai 2020

Re-

Je navigue à vue car je n'ai pas de calendriers partagés.
Néanmoins, en partant de l'hypothèse :
- que tu saches programmer des imports excel sur outlook sur ton propre calendrier
- que le problème vient de référencer le bon calendrier

Alors, de ma compréhension :
1. Ici un fil qui mentionne une macro qui doit se présenter à peu près de la même manière que ta macro

Loading appointments to a non-default Outlook calendar from Excel

I have a project to put employees leave schedules into a shared or global calendar. The appointments save to my default calendar. I have tried a few different approaches. This is the current appr...

stackoverflow.com

>> Et dont je déduis que la problématique essentielle revient à trouver un numéro d'ID (plutôt que son nom d'usage qui est une source continue d'emm.... pour être utilisé en VBA sur les imports / exports je trouve)

3. Et pour retrouver ce numéro, une autre macro à utiliser dans VBE outlook

How to find Calendar ID

I need to find the ID of a Outlook Calendar. It is a public calendar with many contributors/users, but not listed as "shared". I want to automatically export selected calendars to an *.ics. Cur...

stackoverflow.com

>>testé, ça me donne bien un numéro.

Voilà, j'espère que ça pourra t'aider.
Bon courage
zebanx

Lolote83 · 6 Mai 2020

Bonjour Zebanx,
Merci pour les liens transmis. 2 de plus au compteur mais toujours pas de visibilité du calendrier partagé par ma collègue nommé TOTO
Voici une fois un des codes transmis une copie d'écran ou on voit bien apparaitre les calendriers persos mais pas les autres

En parcourant les autres dossiers, impossible de trouver le fameux "TOTO"
Je continue mes recherches mais je commence vraiment a désespérer sachant que je comprend qu'il est très difficile pour l'un d'entre vous de m'aider si vous n'avez pas de calendrier partagé avec quelqu'un pour faire des tests.
Je garde espoir tout de même
@+ Lolote83

zebanx · 6 Mai 2020

Re-

Pas compris au post 1 que tu n'avais pas d'accès à TOTO (avec l'image).
C'est plus un problème d'accessibilité avec des restrictions qu'un problème de code là (non ?) ?
N'y a-t-il pas un problème d'adresse mail à renseigner pour permettre de partager ce calendrier dans une section spécifique sous Outlook ?

https://support.microsoft.com/en-us/help/3205457/you-can-t-access-a-shared-calendar-by-using-outlook-for-a-hidden-mailb

En version 2016, cela - parait - commode à coordonner.

Partager et accéder à un calendrier en mode affichage seul dans Outlook - Support Microsoft

Partagez votre calendrier Outlook avec d’autres personnes.

support.office.com

Bref, ne serait-il pas plus rapide de demander à MICROSOFT directement pour avoir leur avis ?

Bon courage (Même si une fois que tu auras l'affichage du calendrier, ça sera "in the pocket"

)

zebanx

Lolote83 · 6 Mai 2020

Merci Zebanx pour ta persévérance.
Tu n'as pas ouvert la PJ du post#1 ou des explications supplémentaires sont écrites ?
Je sais que certaines personnes n'ouvents pas les PJ donc je mets aussi des copies d'écran, cela peut aider. Si tel est ton cas (et je respecte ce choix) voici donc une nouvelle copie qui t'aidera peut être dans ma problématique.

Comme tu dis :

C'est plus un problème d'accessibilité avec des restrictions qu'un problème de code là (non ?) ?

- Concernant le calendrier "CONTRAT" que j'ai partagé avec ma collègue, elle a tous les droits dessus donc lecture et écriture (mais elle ne peut pas le faire via macro)

- Concernant le calendrier "TOTO" qu'elle à partagé avec moi, j'ai tous les droits dessus donc lecture et écriture (mais je ne peux pas le faire via macro)

Je vais donc parcourir tes nouveaux liens.
Merci beaucoup.
J'aurais pensé tout de même que cette discussion aurait suscité plus d’intérêt pour la communauté et donc plus de participant mais tu es là.
Merci encore, je te tiens au courant
@+ Lolote83

Lolote83 · 9 Mai 2020

Bonjour Zebanx, le forum.
Ça y est, j'ai réussi. Ouf

Comme promis, je transmet donc le code qui permet de créer un RDV sur calendrier Perso et/ou Partagé.
La macro jointe parcours l'ensemble des familles de calendrier, recherche le calendrier passé en paramètre et inscrit les données.
Voici la copie d'écran de mes calendriers et de ce que je n'arrivais pas à faire.

Voici donc la macro pour créer un RDV

VB:

Sub TestAjoutRDV()
    Call AjoutDansCalendrier("Contrat", "Pour Zebanx", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
End Sub

VB:

Sub AjoutDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xDuree, xLieu, xBody, xCatégorie)
    '---------------------------------------------------------------------------------------
    '                                                   Création d'un RDV sur Agenda OUTLOOK
    '---------------------------------------------------------------------------------------
    Dim OLApp As Outlook.Application
    Dim ObjNS As Outlook.Namespace
    Dim ObjExpCal As Outlook.Explorer
    Dim ObjNavMod As Outlook.CalendarModule
    Dim ObjNavCalPart As Outlook.NavigationFolders
    Dim ObjNavFolder As Outlook.NavigationFolder
    Dim FolderPartage As Outlook.Folder
    Dim F
    Dim xTrouve As Boolean

    Set OLApp = CreateObject("outlook.application")
    Set ObjNS = OLApp.Session
    Set ObjExpCal = ObjNS.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set ObjNavMod = ObjExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Mes calendriers").NavigationFolders           'Famille Mes calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Autres calendriers").NavigationFolders        'Famille Autres calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders      'Famille Calendriers partagés


    '--------------------------------------------------------------------------------------
    '     Parcours la liste des familles de calendrier et les calendriers de chaque famille
    '--------------------------------------------------------------------------------------
    xTrouve = False
    xNbrFamCal = ObjNavMod.NavigationGroups.Count
    For F = 1 To xNbrFamCal
        xNbrSousCal = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Count
        For G = 1 To xNbrSousCal
            xNomFamilleCal = ObjNavMod.NavigationGroups.Item(F).Name
            xNomCalendrier = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Item(G).DisplayName
            If xNomCalendrier = xCalendrier Then
                On Error Resume Next
                Set ObjNavCalPart = ObjNavMod.NavigationGroups.Item(xNomFamilleCal).NavigationFolders
                Set ObjNavFolder = ObjNavCalPart(xCalendrier)
                Set MonSousDoss = ObjNavCalPart(G)
                'FoldName = MonSousDoss.Folder.Name & "-" & MonSousDoss.Folder.FullFolderPath
                If Err Then
                    xTrouve = False
                    MsgBox "Calendrier : " & xCalendrier & " non accéssible !!!", vbCritical, "ERREUR"
                Else
                    xTrouve = True
                    xMess = Empty
                    xMess = xMess & "FAMILLE = " & xNomFamilleCal & Chr(13) & Chr(13)
                    xMess = xMess & Space(10) & "CALENDRIER = " & xNomCalendrier
                    MsgBox xMess, vbInformation, "FAMILLE & CALENDRIER"
                End If
                Exit For
            Else
                xTrouve = False
            End If
        Next G
        If xTrouve = True Then
            Exit For
        End If
    Next F
    If xTrouve = False Then
        MsgBox "Calendrier : " & xCalendrier & " non trouvé !!!!", vbCritical, "CALENDRIER"
        Exit Sub
    End If
   
    '--------------------------------------------------------------------------------------
    '                                                                                 Suite
    '--------------------------------------------------------------------------------------
    If MonSousDoss <> Empty Then
        Set FolderPartage = ObjNavFolder.Folder
        On Error GoTo 0
        '---------------------------------------------------------
        '                                          Création du RDV
        '---------------------------------------------------------
        Dim ObjRDV As Outlook.AppointmentItem
        Set ObjRDV = FolderPartage.items.Add
        xStart = xDateDeb & " " & Deux(Hour(xHeurDeb)) & ":" & Deux(Minute(xHeurDeb)) & ":00"
        With ObjRDV
            .Subject = xTitre
            .Body = xBody
            .Start = xStart
            .Duration = xDuree                      'Valeur entière (exemple 30) exprimée en minutes
            .Location = xLieu
            .Categories = xCatégorie                'Exemple : Catégorie Bleu
            .ReminderMinutesBeforeStart = 0
            .ReminderSet = True
            .Display                                'Mettre en commentaire après mise au point
            '.Save
        End With
    End If
End Sub

Puis, dans le même esprit, la suppression d'un RDV déjà créé

VB:

Sub TestSupprRDV()
    Call SupprDansCalendrier("Contrat", "Pour Zebanx", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
End Sub

VB:

Sub SupprDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xDuree, xLieu, xBody, xCatégorie)
    '---------------------------------------------------------------------------------------
    '                                                   Création d'un RDV sur Agenda OUTLOOK
    '---------------------------------------------------------------------------------------
    Dim OLApp As Outlook.Application
    Dim ObjNS As Outlook.Namespace
    Dim ObjExpCal As Outlook.Explorer
    Dim ObjNavMod As Outlook.CalendarModule
    Dim ObjNavCalPart As Outlook.NavigationFolders
    Dim ObjNavFolder As Outlook.NavigationFolder
    Dim CollectionAppointments As Outlook.items
    Dim FolderPartage As Outlook.Folder
    Dim F
    Dim xTrouve As Boolean

    Set OLApp = CreateObject("outlook.application")
    Set ObjNS = OLApp.Session
    Set ObjExpCal = ObjNS.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set ObjNavMod = ObjExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Mes calendriers").NavigationFolders           'Famille Mes calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Autres calendriers").NavigationFolders        'Famille Autres calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders      'Famille Calendriers partagés


    '--------------------------------------------------------------------------------------
    '     Parcours la liste des familles de calendrier et les calendriers de chaque famille
    '--------------------------------------------------------------------------------------
    xTrouve = False
    xNbrFamCal = ObjNavMod.NavigationGroups.Count
    For F = 1 To xNbrFamCal
        xNbrSousCal = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Count
        For G = 1 To xNbrSousCal
            xNomFamilleCal = ObjNavMod.NavigationGroups.Item(F).Name
            xNomCalendrier = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Item(G).DisplayName
            If xNomCalendrier = xCalendrier Then
                On Error Resume Next
                Set ObjNavCalPart = ObjNavMod.NavigationGroups.Item(xNomFamilleCal).NavigationFolders
                Set ObjNavFolder = ObjNavCalPart(xCalendrier)
                Set MonSousDoss = ObjNavCalPart(G)
                'FoldName = MonSousDoss.Folder.Name & "-" & MonSousDoss.Folder.FullFolderPath
                If Err Then
                    xTrouve = False
                    MsgBox "Calendrier : " & xCalendrier & " non accéssible !!!", vbCritical, "ERREUR"
                Else
                    xTrouve = True
                    xMess = Empty
                    xMess = xMess & "FAMILLE = " & xNomFamilleCal & Chr(13) & Chr(13)
                    xMess = xMess & Space(10) & "CALENDRIER = " & xNomCalendrier
                    MsgBox xMess, vbInformation, "FAMILLE & CALENDRIER"
                End If
                Exit For
            Else
                xTrouve = False
            End If
        Next G
        If xTrouve = True Then
            Exit For
        End If
    Next F
    If xTrouve = False Then
        MsgBox "Calendrier : " & xCalendrier & " non trouvé !!!!", vbCritical, "CALENDRIER"
        Exit Sub
    End If
   
    If MonSousDoss <> Empty Then
        '----------------------------------------------------------
        '                       Récupération des données du tableau
        '----------------------------------------------------------
        xStart = xDateDeb & " " & Deux(Hour(xHeurDeb)) & ":" & Deux(Minute(xHeurDeb))
        xConcat = xTitre & "-" & xStart & ":00-" & xCatégorie
           
        'sFilter = "[Start] >= '" & xStart & "'"                                                 'Définit les critères de filtre
        sFilter = "[Start] = '" & xStart & "'"                                                 'Définit les critères de filtre
        Set CollectionAppointments = MonSousDoss.Folder.items.Restrict(sFilter)
   
        '--------------------------------------------------------
        '                         Boucle sur tous les rdv trouvés
        '--------------------------------------------------------
        For Each oAppointment In CollectionAppointments
            xTitRDV = oAppointment.Subject                          'Titre
            xDebRDV = oAppointment.Start                            'Date et Heure de début
            xFinRDV = oAppointment.End                              'Date et Heure de fin
            xEmpRDV = oAppointment.Location                         'Emplacement
            xBodRDV = oAppointment.Body                             'Corps
            xCatRDV = oAppointment.Categories                       'Catégorie (couleur)
            xConcatRDV = xTitRDV & "-" & xDebRDV & "-" & xCatRDV
            If xConcatRDV = xConcat Then
                'MsgBox "Suppression = " & xTitre & " " & xDeb
                oAppointment.Delete
            End If
        Next
    End If
End Sub

puis le code en sus

VB:

Public Function Deux(Tps)
    Deux = Right("00" & Tps, 2)
End Function

Voili voilà.
Je pense qu'il peut être encore améliorable voir étre réduit, mais pour le moment cela fonctionne.
Merci encore Zebanx pour le soutient
@+ Lolote83

zebanx · 9 Mai 2020

Bonjour Lolote83, le forum

Merci et bravo pour avoir réussi avec beaucoup de temps passé et d'abnégation à finaliser ton code.
Sur un sujet qui parait au départ "simple", à savoir de pouvoir choisir un calendrier par son nom sur une seule ligne de code, la longueur du code montre que MS n'a pas simplifié du tout cette partie et que les retours sur la toile étaient bien rares pour ne pas dire quasi-inexistant.

Ce sujet de calendrier partagé semble assez fréquent sur le forum, ces codes devraient aider quelques personnes - dont moi évidemment - du forum.
Il faut t'en remercier donc doublement de nous avoir communiqué des codes complets, bien expliqués et utiles. Le tout avec un titre bien adapté à toute recherche et une présentation dans le 1 et sur le fichier de départ (#1) qui permettra à tous, expérimentés ou non, de bien comprendre la démarche.

Bonne journée à toi.... et bon remplissage

zebanx

Lolote83 · 9 Mai 2020

Re bonjour,
Nouveau défi, faire sensiblement la même chose mais avec GoogleAgenda.
La partie s'annonce difficile.
A bientôt
@+ Lolote83

Compte Supprimé 979 · 9 Mai 2020

Bonjour le fil, Lolote83

Une idée de l'ampleur du travail ici : https://sites.google.com/site/pageabbil/home/goocalendar

Ceci dit, si tu utilises Outlook, pourquoi ne pas lier l'agenda Google

@+

Usine à gaz · 9 Mai 2020

Bonjour Lolote83, Le Forum
J'espère que vous allez bien

N'ayant pas Outlook , je cherche à pouvoir le faire avec Google agenda,
Je suis très intéressé

Si vous trouvez la solution, ça me rendrait un grand service

Avec mes remerciements,
Amicalement,
lionel,

Lolote83 · 10 Mai 2020

Re bonjour à tous,

BrunoM45 :

Ceci dit, si tu utilises Outlook, pourquoi ne pas lier l'agenda Google

C'est juste que losque j'ai parlé à ma collègue de la réussite sur Outlook, elle m'a dit quelle connaissait quelqu'un qui utilise Excel et Google Agenda mais pas Outlook, d'ou le nouveau defi.
De plus, j'ai parcouru le lien donné. J'ai même téléchargé le fichier joint et parcouru le code, mais là, ça dépasse mes capacités. En plus, j'ai même une erreur sur le code mais si quelqu'un passe par là et trouve une solution, je suis preneur.

Arthour973 :
Pour l'instant, je me contente depuis ma base XL, d'extraire les données au format ICAL que j'importe ensuite manuellement sur mon calendrier google agenda

Affaire à suivre
Merci encore à tous
@+ Lolote83

zebanx · 10 Mai 2020

Lolote83 à dit:
Re bonjour à tous,

BrunoM45 :

C'est juste que losque j'ai parlé à ma collègue de la réussite sur Outlook, elle m'a dit quelle connaissait quelqu'un qui utilise Excel et Google Agenda mais pas Outlook, d'ou le nouveau defi.
De plus, j'ai parcouru le lien donné. J'ai même téléchargé le fichier joint et parcouru le code, mais là, ça dépasse mes capacités. En plus, j'ai même une erreur sur le code mais si quelqu'un passe par là et trouve une solution, je suis preneur.

Bonjour Louloute, le forum

@louloute83

La dame qui a vu la dame qui a vu l'ours.
Ce serait peut-être mieux que ta collègue te donne le contact de "quelqu'un" (non?).
Le défi, pas long et plus rapide, c'est qu'elle cherche dans son agenda ce contact.

Un déconfinement de numéro en quelque sorte.

Bonne journée
zebanx

chagatte · 7 Janvier 2021

Lolote83 à dit:
Merci Zebanx pour ta persévérance.
Tu n'as pas ouvert la PJ du post#1 ou des explications supplémentaires sont écrites ?
Je sais que certaines personnes n'ouvents pas les PJ donc je mets aussi des copies d'écran, cela peut aider. Si tel est ton cas (et je respecte ce choix) voici donc une nouvelle copie qui t'aidera peut être dans ma problématique.
Regarde la pièce jointe 1065930
Comme tu dis :

- Concernant le calendrier "CONTRAT" que j'ai partagé avec ma collègue, elle a tous les droits dessus donc lecture et écriture (mais elle ne peut pas le faire via macro)

- Concernant le calendrier "TOTO" qu'elle à partagé avec moi, j'ai tous les droits dessus donc lecture et écriture (mais je ne peux pas le faire via macro)

Je vais donc parcourir tes nouveaux liens.
Merci beaucoup.
J'aurais pensé tout de même que cette discussion aurait suscité plus d’intérêt pour la communauté et donc plus de participant mais tu es là.
Merci encore, je te tiens au courant
@+ Lolote83

Lolote83 à dit:

Bonjour Zebanx, le forum.
Ça y est, j'ai réussi. Ouf

Comme promis, je transmet donc le code qui permet de créer un RDV sur calendrier Perso et/ou Partagé.
La macro jointe parcours l'ensemble des familles de calendrier, recherche le calendrier passé en paramètre et inscrit les données.
Voici la copie d'écran de mes calendriers et de ce que je n'arrivais pas à faire.
Regarde la pièce jointe 1066407
Voici donc la macro pour créer un RDV

VB:

Sub TestAjoutRDV()
    Call AjoutDansCalendrier("Contrat", "Pour Zebanx", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
End Sub

VB:

Sub AjoutDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xDuree, xLieu, xBody, xCatégorie)
    '---------------------------------------------------------------------------------------
    '                                                   Création d'un RDV sur Agenda OUTLOOK
    '---------------------------------------------------------------------------------------
    Dim OLApp As Outlook.Application
    Dim ObjNS As Outlook.Namespace
    Dim ObjExpCal As Outlook.Explorer
    Dim ObjNavMod As Outlook.CalendarModule
    Dim ObjNavCalPart As Outlook.NavigationFolders
    Dim ObjNavFolder As Outlook.NavigationFolder
    Dim FolderPartage As Outlook.Folder
    Dim F
    Dim xTrouve As Boolean

    Set OLApp = CreateObject("outlook.application")
    Set ObjNS = OLApp.Session
    Set ObjExpCal = ObjNS.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set ObjNavMod = ObjExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Mes calendriers").NavigationFolders           'Famille Mes calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Autres calendriers").NavigationFolders        'Famille Autres calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders      'Famille Calendriers partagés


    '--------------------------------------------------------------------------------------
    '     Parcours la liste des familles de calendrier et les calendriers de chaque famille
    '--------------------------------------------------------------------------------------
    xTrouve = False
    xNbrFamCal = ObjNavMod.NavigationGroups.Count
    For F = 1 To xNbrFamCal
        xNbrSousCal = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Count
        For G = 1 To xNbrSousCal
            xNomFamilleCal = ObjNavMod.NavigationGroups.Item(F).Name
            xNomCalendrier = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Item(G).DisplayName
            If xNomCalendrier = xCalendrier Then
                On Error Resume Next
                Set ObjNavCalPart = ObjNavMod.NavigationGroups.Item(xNomFamilleCal).NavigationFolders
                Set ObjNavFolder = ObjNavCalPart(xCalendrier)
                Set MonSousDoss = ObjNavCalPart(G)
                'FoldName = MonSousDoss.Folder.Name & "-" & MonSousDoss.Folder.FullFolderPath
                If Err Then
                    xTrouve = False
                    MsgBox "Calendrier : " & xCalendrier & " non accéssible !!!", vbCritical, "ERREUR"
                Else
                    xTrouve = True
                    xMess = Empty
                    xMess = xMess & "FAMILLE = " & xNomFamilleCal & Chr(13) & Chr(13)
                    xMess = xMess & Space(10) & "CALENDRIER = " & xNomCalendrier
                    MsgBox xMess, vbInformation, "FAMILLE & CALENDRIER"
                End If
                Exit For
            Else
                xTrouve = False
            End If
        Next G
        If xTrouve = True Then
            Exit For
        End If
    Next F
    If xTrouve = False Then
        MsgBox "Calendrier : " & xCalendrier & " non trouvé !!!!", vbCritical, "CALENDRIER"
        Exit Sub
    End If
  
    '--------------------------------------------------------------------------------------
    '                                                                                 Suite
    '--------------------------------------------------------------------------------------
    If MonSousDoss <> Empty Then
        Set FolderPartage = ObjNavFolder.Folder
        On Error GoTo 0
        '---------------------------------------------------------
        '                                          Création du RDV
        '---------------------------------------------------------
        Dim ObjRDV As Outlook.AppointmentItem
        Set ObjRDV = FolderPartage.items.Add
        xStart = xDateDeb & " " & Deux(Hour(xHeurDeb)) & ":" & Deux(Minute(xHeurDeb)) & ":00"
        With ObjRDV
            .Subject = xTitre
            .Body = xBody
            .Start = xStart
            .Duration = xDuree                      'Valeur entière (exemple 30) exprimée en minutes
            .Location = xLieu
            .Categories = xCatégorie                'Exemple : Catégorie Bleu
            .ReminderMinutesBeforeStart = 0
            .ReminderSet = True
            .Display                                'Mettre en commentaire après mise au point
            '.Save
        End With
    End If
End Sub

Puis, dans le même esprit, la suppression d'un RDV déjà créé

VB:

Sub TestSupprRDV()
    Call SupprDansCalendrier("Contrat", "Pour Zebanx", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
End Sub

VB:

Sub SupprDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xDuree, xLieu, xBody, xCatégorie)
    '---------------------------------------------------------------------------------------
    '                                                   Création d'un RDV sur Agenda OUTLOOK
    '---------------------------------------------------------------------------------------
    Dim OLApp As Outlook.Application
    Dim ObjNS As Outlook.Namespace
    Dim ObjExpCal As Outlook.Explorer
    Dim ObjNavMod As Outlook.CalendarModule
    Dim ObjNavCalPart As Outlook.NavigationFolders
    Dim ObjNavFolder As Outlook.NavigationFolder
    Dim CollectionAppointments As Outlook.items
    Dim FolderPartage As Outlook.Folder
    Dim F
    Dim xTrouve As Boolean

    Set OLApp = CreateObject("outlook.application")
    Set ObjNS = OLApp.Session
    Set ObjExpCal = ObjNS.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set ObjNavMod = ObjExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Mes calendriers").NavigationFolders           'Famille Mes calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Autres calendriers").NavigationFolders        'Famille Autres calendriers
    'Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders      'Famille Calendriers partagés


    '--------------------------------------------------------------------------------------
    '     Parcours la liste des familles de calendrier et les calendriers de chaque famille
    '--------------------------------------------------------------------------------------
    xTrouve = False
    xNbrFamCal = ObjNavMod.NavigationGroups.Count
    For F = 1 To xNbrFamCal
        xNbrSousCal = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Count
        For G = 1 To xNbrSousCal
            xNomFamilleCal = ObjNavMod.NavigationGroups.Item(F).Name
            xNomCalendrier = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Item(G).DisplayName
            If xNomCalendrier = xCalendrier Then
                On Error Resume Next
                Set ObjNavCalPart = ObjNavMod.NavigationGroups.Item(xNomFamilleCal).NavigationFolders
                Set ObjNavFolder = ObjNavCalPart(xCalendrier)
                Set MonSousDoss = ObjNavCalPart(G)
                'FoldName = MonSousDoss.Folder.Name & "-" & MonSousDoss.Folder.FullFolderPath
                If Err Then
                    xTrouve = False
                    MsgBox "Calendrier : " & xCalendrier & " non accéssible !!!", vbCritical, "ERREUR"
                Else
                    xTrouve = True
                    xMess = Empty
                    xMess = xMess & "FAMILLE = " & xNomFamilleCal & Chr(13) & Chr(13)
                    xMess = xMess & Space(10) & "CALENDRIER = " & xNomCalendrier
                    MsgBox xMess, vbInformation, "FAMILLE & CALENDRIER"
                End If
                Exit For
            Else
                xTrouve = False
            End If
        Next G
        If xTrouve = True Then
            Exit For
        End If
    Next F
    If xTrouve = False Then
        MsgBox "Calendrier : " & xCalendrier & " non trouvé !!!!", vbCritical, "CALENDRIER"
        Exit Sub
    End If
  
    If MonSousDoss <> Empty Then
        '----------------------------------------------------------
        '                       Récupération des données du tableau
        '----------------------------------------------------------
        xStart = xDateDeb & " " & Deux(Hour(xHeurDeb)) & ":" & Deux(Minute(xHeurDeb))
        xConcat = xTitre & "-" & xStart & ":00-" & xCatégorie
          
        'sFilter = "[Start] >= '" & xStart & "'"                                                 'Définit les critères de filtre
        sFilter = "[Start] = '" & xStart & "'"                                                 'Définit les critères de filtre
        Set CollectionAppointments = MonSousDoss.Folder.items.Restrict(sFilter)
  
        '--------------------------------------------------------
        '                         Boucle sur tous les rdv trouvés
        '--------------------------------------------------------
        For Each oAppointment In CollectionAppointments
            xTitRDV = oAppointment.Subject                          'Titre
            xDebRDV = oAppointment.Start                            'Date et Heure de début
            xFinRDV = oAppointment.End                              'Date et Heure de fin
            xEmpRDV = oAppointment.Location                         'Emplacement
            xBodRDV = oAppointment.Body                             'Corps
            xCatRDV = oAppointment.Categories                       'Catégorie (couleur)
            xConcatRDV = xTitRDV & "-" & xDebRDV & "-" & xCatRDV
            If xConcatRDV = xConcat Then
                'MsgBox "Suppression = " & xTitre & " " & xDeb
                oAppointment.Delete
            End If
        Next
    End If
End Sub

puis le code en sus

VB:

Public Function Deux(Tps)
    Deux = Right("00" & Tps, 2)
End Function

Voili voilà.
Je pense qu'il peut être encore améliorable voir étre réduit, mais pour le moment cela fonctionne.
Merci encore Zebanx pour le soutient
@+ Lolote83

Bonjour,

La macro fonctionne très bien. J'ai cependant un problème avec. J'ai deux calendriers qui ont le même nom (Dossier = "Mes Calendriers", nom des calendriers = "Calendrier") dans le même dossier et c'est d'ailleurs souvent le cas, or je ne peux pas les renommer. La macro va donc écrire dans le premier qui vient, or moi je souhaiterai qu'elle écrivent dans le deuxième. N'y a t-il pas moyen de différencier les calendriers par un identifiant unique pour la rendre encore plus performante quand ce cas là se présente ?

Cordialement,

Chagatte

XL 2016 Inscrire des RDV dans Outlook (calendrier partagé) via Excel macro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

Compte Supprimé 979

Guest

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Nouveau

Discussions similaires

Partager cette page

Statistiques des forums