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

Lolote83

XLDnaute Barbatruc
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 ici.
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
1588664924112.png

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
 

Pièces jointes

  • Forum - Liaison Outlook via excel.xlsm
    45.1 KB · Affichages: 28
C

Compte Supprimé 979

Guest
Bonjour Lolote83

- 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)
C'est uniquement un problème de droit je pense ;)

Avez-vous regardé les "Autorisations du calendrier", il faut que vous soyer ajouter chacune à pouvoir le consulter

@+
 

Lolote83

XLDnaute Barbatruc
Bonjour BrunoM45,
Merci de te pencher sur mon problème.
J'y suis encore mais j'avance un peu.
Peut être n'as tu pas ouvert la pièce jointe ou j'explique d'avantage.
Concernant ta remarque : Nous avons chacun les droits ouverts en lecture et écriture.
Merci et a bientôt
Je continue mes recherches
@+ Lolote83
 
C

Compte Supprimé 979

Guest
Re,

Effectivement, je n'avais pas ouvert le fichier, mais cela ne m'avance guère

Une question qui me vient à l'esprit, pour travailler sur 2 calendriers partagés mais séparés
 

Lolote83

XLDnaute Barbatruc
Re bonjour,
Je pensais que les explications fournies dans le fichier joint t'aiderai à mieux cibler ma demande.
Cependant, à force de triturer tous les codes glanés par ci et par là, je viens à l'instant de parvenir à mes fins (enfin j'espère)
Il faut que je vois maintenant avec ma collègue si cela fonctionne de son coté.
Si tout est positif et validé, je ne manquerais pas de partager ce code.
Donc certainement à très bientôt pour la solution.
4 jours acharnés a chercher, trituré, reformuler, bref me casser la tête.
A bientôt
@+ Lolote83
 

Lolote83

XLDnaute Barbatruc
Bonjour BrunoM45, le forum.
Ça y est, j'ai réussi. Ouf :p:p:p
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 BrunoM45", "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 BrunoM45", "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

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

Compte Supprimé 979

Guest
Salut Lolote83

Merci pour ton retour et pour le code qui aidera les personnes dans la même situation

Edit de 13h, le code peut être optimisé, le voici ;)
VB:
Option Explicit

' Déclaration des variables utiles pour tout le module
Dim FlgErr As Boolean
Dim FolderPartage As Outlook.Folder

'---------------------------------------------------------------------------------------
' Création d'un RDV sur Agenda OUTLOOK
'---------------------------------------------------------------------------------------
Sub AjoutDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xDuree, xLieu, xBody, xCatégorie)
  Dim xStart As String
  Dim ObjRDV As Outlook.AppointmentItem
  ' Définir le FLAG d'erreur à FAUX
  FlgErr = False
  ' Trouver et définir le calendrier sur lequel travailler
  Call TrouveDefCal(xCalendrier)
  ' Si pas d'erreur rencontrée
  If FlgErr = False Then
    ' Création du RDV
    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

'---------------------------------------------------------------------------------------
' Supression d'un RDV sur Agenda OUTLOOK
'---------------------------------------------------------------------------------------
Sub SupprDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xCatégorie)
  Dim oAppointment As Outlook.AppointmentItem
  Dim CollectionAppointments As Outlook.Items
  Dim xConcat As String, xConcatRDV As String, sFilter As String, xStart As String
  Dim xTitRDV As String, xDebRDV As String, xFinRDV As String, xEmpRDV As String, xBodRDV As String, xCatRDV As String
  ' Définir le FLAG d'erreur à FAUX
  FlgErr = False
  ' Trouver et définir le calendrier sur lequel travailler
  Call TrouveDefCal(xCalendrier)
  ' Si pas d'erreur rencontrée
  If FlgErr = False Then
    '----------------------------------------------------------
    ' Récupération des données du tableau
    '----------------------------------------------------------
    xStart = xDateDeb & " " & Deux(Hour(xHeurDeb)) & ":" & Deux(Minute(xHeurDeb))
    xConcat = xTitre & "-" & xStart & ":00-" & xCatégorie
    'Définit les critères de filtre
    sFilter = "[Start] = '" & xStart & "'"
    Set CollectionAppointments = FolderPartage.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
      ' RDV trouvé, le supprimer
      If xConcatRDV = xConcat Then oAppointment.Delete
    Next
  End If
  ' Effacer les variables objet pour libérer de la mémoire
  Set CollectionAppointments = Nothing
End Sub

Sub TrouveDefCal(xCalendrier)
  Dim OLApp As Outlook.Application
  Dim ObjNS As Outlook.Namespace
  Dim ObjExpCal As Outlook.Explorer
  Dim ObjNavCalPart As Outlook.NavigationFolders
  Dim ObjNavFolder As Outlook.NavigationFolder
  Dim ObjNavMod As Outlook.CalendarModule
  Dim xNbrFamCal As Integer, xNbrSousCal As Integer
  Dim xNomFamilleCal As String, xNomCalendrier As String
  Dim xMess As String
  Dim F As Integer, G As Integer
  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)
  '--------------------------------------------------------------------------------------
  ' 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  ' Juste pour info
      xNomCalendrier = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Item(G).DisplayName
      ' Si le calendrier trouvé = celui cherché
      If xNomCalendrier = xCalendrier Then
        On Error Resume Next
        Set ObjNavCalPart = ObjNavMod.NavigationGroups.Item(xNomFamilleCal).NavigationFolders
        Set ObjNavFolder = ObjNavCalPart(xCalendrier)
        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"
          ' Définir le dossier de travail
          Set FolderPartage = ObjNavFolder.Folder
          Exit For
        End If
      End If
    Next G
    If xTrouve Then Exit For
  Next F
  ' FLAG d'erreur
  FlgErr = Not xTrouve
  ' Petit message si non trouvé
  If xTrouve = False Then
    MsgBox "Calendrier : " & xCalendrier & " non trouvé !!!!", vbCritical, "CALENDRIER"
  End If
  ' Effacer les variables objet pour libérer de la mémoire
  Set OLApp = Nothing: Set ObjNS = Nothing
  Set ObjExpCal = Nothing: Set ObjNavMod = Nothing
  Set ObjNavCalPart = Nothing: Set ObjNavFolder = Nothing
End Sub

Au plaisir
 
Dernière modification par un modérateur:

Lolote83

XLDnaute Barbatruc
Re Bonjour,
Nouveau défi mais avec GoogleAgenda.
Suivre la discution originale ici :
@+ Lolote83
 

Lolote83

XLDnaute Barbatruc
Bonjour Barbichette, tous les autres.
Effectivement, en relisant, j'ai oublié la petite fonction DEUX
Mais on peut alors remplacer la ligne par :
xStart = xDateRDV & " " & Right("00" & Hour(xHeurRDV), 2) & ":" & Right("00" & Minute(xHeurRDV), 2) & ":00"
sinon la fonction était
Public Function Deux(Tps)
Deux = Right("00" & Tps, 2)
End Function
que l'on appelait donc via la ligne
xStart = xDateRDV & " " & Deux(Hour(xHeurRDV)) & ":" & Deux(Minute(xHeurRDV))
comme l'indique Barbichette.
@+ Lolote83
 

Barbichette

XLDnaute Nouveau
Ok, ca marche mieux en effet.

Je suis toutefois confronté à un nouveau problème

Le calendrier que je cherche à atteindre est le calendrier "Calendrier Fred" dans la famille "iCloud"
Hors "Calendrier Fred" est également présent dans la famille "Mes calendriers" en tant que sauvegarde de iCloud.

Quelle pourrait être alors la syntaxe pour atteindre le bon calendrier ?

Merci
 

Discussions similaires