Discussion :

[Lolote83]

Bonjour à tous et à toutes,
Cela fait maintenant plusieurs jours que je parcours le Net à la recherche d'une solution.
J'ai vu beaucoup de réponses mais soit je n'ai ps réussi à les adapter à mon projet soit cela n'aboutissait pas au résultat escompté.
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 mon 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)
La copie d'écran ci-dessous résume bien la demande



Merci par avance à toutes et à tous.
Je précise que quand j'écris : "je peux inscrire des RDV sur ce calendrier", c'est bien par macro dont je veux parler. Le calendrier partagé peut être rempli à la mano sans aucun problème mais pas via la macro
Je patauge encore avec ce forum pour lequel je me suis inscrit aujourd'hui.
@+ Lolote83

[Lolote83]

Bonjour le forum.

Ça y est, j'ai réussi. Ouf

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

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
 
Sub TestAjoutRDV()
 
Call AjoutDansCalendrier("Contrat", "Pour Forum Developpez", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
 
End Sub

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
 
 
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éé

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
 
Sub TestSupprRDV()
 
Call SupprDansCalendrier("Contrat", "Pour Forum Developpez", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
 
End Sub

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
 
 
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.

@+ Lolote83

[Joel971]

Bonjour le forum.

Ça y est, j'ai réussi. Ouf

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

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
 
Sub TestAjoutRDV()
 
Call AjoutDansCalendrier("Contrat", "Pour Forum Developpez", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
 
End Sub

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
 
 
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éé

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
 
Sub TestSupprRDV()
 
Call SupprDansCalendrier("Contrat", "Pour Forum Developpez", "09/05/2020", "18:00:00", 60, "OUF !!!", "Enfin, j'ai réussi", "Catégorie Vert")
 
End Sub

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
 
 
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.

@+ Lolote83

[Lolote83]

Bonjour Joel971.
J'espère que la macro fournie pourra te servir
@+ Lolote83

[Joel971]

Bonjour Joel971.
J'espère que la macro fournie pourra te servir
@+ Lolote83