|
Membre régulier
Inscription : mars 2008 Messages : 210 Détails du profil  Informations forums : Inscription : mars 2008 Messages : 210 Points : 70 Points : 70
|
Bonjour,
Il s'agit d'une modification de l'agenda d'USER (celui permettant d'avoir plusieurs rdv au même moment) dans lequel j'ai ajouté la fonction OUTLOOK (modification, ajout, suppression).
Sur le formulaire d'ajout de rdv (F_rendezvous), j'ai un bouton ajout avec ce code :
Code :
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
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
| Dim nb1 As Integer, id1 As Integer
Dim HD As Date, HF As Date
Dim HD1 As Date, HF1 As Date
Dim rsRdv As DAO.Recordset
Dim i As Integer, trouve As Boolean, LstNR As String
Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Dim ACTDATE As String
Dim ActHeure As String
Dim Sujet As String
Dim NvDate As String
Dim NvHeure As String
Dim NvHeurefin As String
Dim filtre As String
Dim DATEDD As Date
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Dim rst As DAO.Recordset
Dim Msg As String
Dim Db As DAO.Database
Dim sql As String
Set Db = CurrentDb
Me!Memo = Me.NC.Column(0) & " - " & Me.Type & " - " & Me.Activité & " - " & Me.statut & " - " & Me.Lieu & " - " & Me.Texte213
DoCmd.RunCommand acCmdSaveRecord
' Quitter la procédure si le rendez-vous a été ajouté à Outlook.
If Me!ajoutéàoutlook = True Then
ACTDATE = Me.dateRDV1outlook & " " & Me.HoraireDoutlook 'Me.Texte193 'Texte5 ' date de recherche du rdv à modifier
' DATEDD = CDate(ACTDATE) ' conversion de la chaine au format date
DATEDD = Me.dateRDV1outlook & " " & Me.HoraireDoutlook
Sujet = Me.Texte197 'identification du rdv que l'on cherche à partir du sujet
'NvDate = Me.Texte12 ' Nouvelle date de début
'NvHeure = Me.Texte14 ' Nouvelle heure
NvHeure = Me.HoraireD ' Nouvelle heure
'nVSubject = Me.Texte18 ' Nouveau sujet
NvHeurefin = Me.HoraireF
'NvHeurefin = Me.Texte48 ' nouvelle heure fin
'NvDatefin = Me.Texte52 'nouvelle date de fin
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
myAppointments.sort "[Start]"
myAppointments.IncludeRecurrences = True
'Création du filtre pour la recherche
filtre = "[Start] = " & Chr(34) & ACTDATE & Chr(34) & ""
filtre = filtre + " and [subject]= " & Chr(34) & Sujet & Chr(34) & ""
' MsgBox Filtre
' MsgBox Filtre
Set currentAppointment = myAppointments.Find(filtre)
While TypeName(currentAppointment) <> "Nothing"
'MsgBox currentAppointment.subject & " " & currentAppointment.Duration
'Déplacement du rdv
currentAppointment.Start = DateRdV1 & " " & HoraireD
currentAppointment.subject = NC.Column(0) & " " & NR
'currentAppointment.Body = Me.Memo
currentAppointment.End = DateRdV2 & " " & HoraireF
If Me.Type Like "*audience*" Then currentAppointment.Categories = "catégorie rouge"
If Me.Type Like "*cabinet*" Then currentAppointment.Categories = "catégorie bleue"
If Me.Type Like "*expertise*" Then currentAppointment.Categories = "catégorie rouge"
If Me.Type Like "*extérieur*" Then currentAppointment.Categories = "catégorie rouge"
If Not IsNull(Me!Memo) Then currentAppointment.Body = Me!Memo
If Not IsNull(Me!Lieu) Then currentAppointment.Location = Me!Lieu
If Me!statut = "absent du bureau" Then currentAppointment.BusyStatus = olOutOfOffice
If Me!statut = "occupé" Then currentAppointment.BusyStatus = olBusy
If Me!statut = "libre" Then currentAppointment.BusyStatus = olFree
If Me!statut = "provisoire" Then currentAppointment.BusyStatus = olTentative
'Sauvegarde de la modification
currentAppointment.Save
'Recherche s'il existe d'autres rdv correspondant aux critères
Set currentAppointment = myAppointments.FindNext
Wend
Msg = "Le rendez-vous a été déplacé. Vous pouvez fermer la fenêtre."
' Si les zones de texte "NC" ou "Memo" ne sont pas vides
If ((Me!NC <> "") And Not IsNull(Me!NC)) Or _
((Me!Memo <> "") And Not IsNull(Me!Memo)) Then
HD = CDate(Format(Me!DateRdV1, "dd/mm/yy ") & Me!HoraireD)
HF = CDate(Format(Me!DateRdV2, "dd/mm/yy ") & Me!HoraireF)
' sql = "INSERT INTO INTERVENTION (Date,DATEFIN,RVheure,HeureFin,N°dossier) VALUES """
' & Me!DateRdV1, 'dd/mm/yy ' & """ AS Expr1, """ _
' & Me!DateRdV2, 'dd/mm/yy ' & """ AS Expr2, """ _
' & Me!HoraireD & """ AS Expr3, """ _
' & Me!HoraireF & """ AS Expr4, """ _
' & Me!NC & """ AS Expr5 ;"
'DoCmd.RunSQL sql
If (Format(HF, "hh:nn") <= "19:00") And (HD < HF) Then
If (Me.DataEntry = True) Then
id1 = 1: nb1 = 1
Set rsRdv = CurrentDb.OpenRecordset("T_RendezVous", dbOpenSnapshot)
LstNR = "(" & CStr(NR) & ")"
ListerRdv rsRdv, LstNR, HD, HF
rsRdv.Close
Set rsRdv = Nothing
Me!HoraireDebut = HD
Me!horairefin = HF
Me!Id = id1
Me!Nb = nb1
Me.Requery
If InStr(LstNR, ",") <> 0 Then
MajRdv LstNR
End If
Else
HD1 = CDate(Me!HoraireDebut)
HF1 = CDate(Me!horairefin)
Me!HoraireDebut = HD
Me!horairefin = HF
Me.Requery
id1 = 1: nb1 = 1
Set rsRdv = CurrentDb.OpenRecordset("T_RendezVous", dbOpenSnapshot)
LstNR = "(" & CStr(NR) & ")"
ListerRdv rsRdv, LstNR, HD1, HF1
rsRdv.Close
Set rsRdv = Nothing
MajRdv LstNR
'------------------------------------------------------------------
Set rsRdv = CurrentDb.OpenRecordset("T_RendezVous", dbOpenSnapshot)
LstNR = "(" & CStr(NR) & ")"
ListerRdv rsRdv, LstNR, HD, HF
rsRdv.Close
Set rsRdv = Nothing
MajRdv LstNR
End If
MajPlanning
Dim SQL2 As String
SQL2 = "UPDATE T_rendezvous SET opérateur = texte209 WHERE (T_rendezvous.nr = forms!f_rendezvouscopie!nr);"
DoCmd.RunSQL SQL2
'sql4 = "UPDATE T_rendezvous SET gestionnaire = gestionnaire WHERE (T_rendezvous.nr = forms!f_rendezvouscopie!nr);"
'DoCmd.RunSQL sql4
DoCmd.Close
Else
MsgBox ("Saisie incorrecte !")
End If
Else
MsgBox ("Saisie incorrecte !")
End If
'MsgBox " [rdv existe déjà] Outlook et Sénèque ont été mis à jour. "
Exit Sub
' Ajouter un nouveau rendez-vous dans outook et seneque.
Else
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Set OutObj = CreateObject("outlook.application")
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
With OutAppt
.Start = Me!DateRdV1 & " " & Me!HoraireD
.End = Me!DateRdV2 & " " & Me!HoraireF
.subject = NC.Column(0) & " " & NR 'N°dossier_gestion & " " & Me!Pour & "/" & Me!Contre & " - " & Me!Type & " - " & Me!Activité & " - " & Me!statut
.Body = Me.Memo
If Me.Type Like "*audience*" Then .Categories = "catégorie rouge"
If Me.Type Like "*cabinet*" Then .Categories = "catégorie bleue"
If Me.Type Like "*expertise*" Then .Categories = "catégorie rouge"
If Me.Type Like "*extérieur*" Then .Categories = "catégorie rouge"
If Not IsNull(Me!Memo) Then .Body = Me!Memo
If Not IsNull(Me!Lieu) Then .Location = Me!Lieu
If Me!statut = "absent du bureau" Then .BusyStatus = olOutOfOffice
If Me!statut = "occupé" Then .BusyStatus = olBusy
If Me!statut = "libre" Then .BusyStatus = olFree
If Me!statut = "provisoire" Then .BusyStatus = olTentative
' If Me!RVRAPPEL Then
' .ReminderMinutesBeforeStart = Me!MinutesRappel
' .ReminderSet = True
.Save
'End If
End With
' Libérez la variable objet Outlook.
Set OutObj = Nothing
' Définir l'indicateur AjoutéàOutlook, enregistrer, afficher un message.
' DoCmd.RunCommand acCmdSaveRecord
Me.ajoutéàoutlook = True
MsgBox "rdv ajouté à outlook"
' Valide les choix effectués sur le formulaire "F_RendezVous"
' Si les zones de texte "NC" ou "Memo" ne sont pas vides
If ((Me!NC <> "") And Not IsNull(Me!NC)) Or _
((Me!Memo <> "") And Not IsNull(Me!Memo)) Then
HD = CDate(Format(Me!DateRdV1, "dd/mm/yy ") & Me!HoraireD)
HF = CDate(Format(Me!DateRdV2, "dd/mm/yy ") & Me!HoraireF)
' sql = "INSERT INTO INTERVENTION (Date,DATEFIN,RVheure,HeureFin,N°dossier) VALUES """
' & Me!DateRdV1, 'dd/mm/yy ' & """ AS Expr1, """ _
' & Me!DateRdV2, 'dd/mm/yy ' & """ AS Expr2, """ _
' & Me!HoraireD & """ AS Expr3, """ _
' & Me!HoraireF & """ AS Expr4, """ _
' & Me!NC & """ AS Expr5 ;"
'DoCmd.RunSQL sql
If (Format(HF, "hh:nn") <= "19:00") And (HD < HF) Then
If (Me.DataEntry = True) Then
id1 = 1: nb1 = 1
Set rsRdv = CurrentDb.OpenRecordset("T_RendezVous", dbOpenSnapshot)
LstNR = "(" & CStr(NR) & ")"
ListerRdv rsRdv, LstNR, HD, HF
rsRdv.Close
Set rsRdv = Nothing
Me!HoraireDebut = HD
Me!horairefin = HF
Me!Id = id1
Me!Nb = nb1
Me.Requery
If InStr(LstNR, ",") <> 0 Then
MajRdv LstNR
End If
SendKeys "{ENTER}", False
Else
HD1 = CDate(Me!HoraireDebut)
HF1 = CDate(Me!horairefin)
Me!HoraireDebut = HD
Me!horairefin = HF
Me.Requery
id1 = 1: nb1 = 1
Set rsRdv = CurrentDb.OpenRecordset("T_RendezVous", dbOpenSnapshot)
LstNR = "(" & CStr(NR) & ")"
ListerRdv rsRdv, LstNR, HD1, HF1
rsRdv.Close
Set rsRdv = Nothing
MajRdv LstNR
SendKeys "{ENTER}", False
'------------------------------------------------------------------
Set rsRdv = CurrentDb.OpenRecordset("T_RendezVous", dbOpenSnapshot)
LstNR = "(" & CStr(NR) & ")"
ListerRdv rsRdv, LstNR, HD, HF
rsRdv.Close
Set rsRdv = Nothing
MajRdv LstNR
End If
MajPlanning
SendKeys "{ENTER}", False
Dim SQL3 As String
SQL3 = "UPDATE T_rendezvous SET opérateur = texte209 WHERE (T_rendezvous.nr = forms!f_rendezvouscopie!nr);"
DoCmd.RunSQL SQL3
'sql5 = "UPDATE T_rendezvous SET gestionnaire = texte209 WHERE (T_rendezvous.nr = forms!f_rendezvouscopie!nr);"
'DoCmd.RunSQL sql2
DoCmd.Close
Else
MsgBox ("Saisie incorrecte !")
End If
Else
MsgBox ("Saisie incorrecte !")
End If
End If
Exit Sub
AjoutRV_Err:
MsgBox " Erreur " & err.Number & vbCrLf & err.Description
Exit Sub
end sub |
Cela appelle les modules suivants :
Code :
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
| Public Sub MajRdv(LstNR As String)
Dim Db As DAO.Database
Dim rs As DAO.Recordset
Dim rsRdv As DAO.Recordset
Dim LeSql As String, LeSql1 As String
Dim b As Variant, l As String
Dim HD As Date, HF As Date
Dim Nb As Integer
Dim i As Integer
LeSql = "select * " & _
"from T_RendezVous " & _
"where NR In " & LstNR & _
" order by HoraireDebut, HoraireFin Desc, NR;"
Set Db = CurrentDb
Set rsRdv = Db.OpenRecordset(LeSql, dbOpenSnapshot)
i = 1
HD = rsRdv!HoraireDebut
HF = rsRdv!horairefin
NR = rsRdv!NR
l = "(" & rsRdv!NR & ")"
Set rs = Db.OpenRecordset("T_RendezVous", dbOpenSnapshot)
ListerRdv rs, l, HD, HF
rs.Close
Set rs = Nothing
MajRdv1 l
rsRdv.FindFirst "HoraireDebut>=" & FormatDateUS(HF)
Do Until rsRdv.NoMatch
HD = rsRdv!HoraireDebut
HF = rsRdv!horairefin
l = "(" & rsRdv!NR & ")"
Set rs = Db.OpenRecordset("T_RendezVous", dbOpenSnapshot)
ListerRdv rs, l, HD, HF
rs.Close
Set rs = Nothing
MajRdv1 l
rsRdv.FindNext "HoraireDebut>=" & FormatDateUS(HF)
Loop
rsRdv.Close
Set rsRdv = Nothing
Set Db = Nothing
End Sub |
et
Code :
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
| Public Sub MajRdv1(LstNR As String)
Dim Db As Database
Dim rsRdv As DAO.Recordset
Dim LeSql As String
Dim b As Variant, l1 As String, l2 As String
Dim HD As Date, HF As Date
Dim Nb As Integer
Dim i As Integer
LeSql = "select * " & _
"from T_RendezVous " & _
"where NR In " & LstNR & _
" order by HoraireDebut, HoraireFin Desc, NR;"
Set Db = CurrentDb
Set rsRdv = Db.OpenRecordset(LeSql, dbOpenDynaset)
i = 1
l1 = vbNullString
l2 = "("
Do Until rsRdv.EOF
HD = rsRdv!HoraireDebut
HF = rsRdv!horairefin
NR = rsRdv!NR
rsRdv.Edit
rsRdv!Id = i
rsRdv.Update
l1 = l1 & "(" & CStr(rsRdv!NR) & ")"
If l2 = "(" Then
l2 = "(" & CStr(rsRdv!NR) & ")"
Else
l2 = Left(l2, Len(l2) - 1) & "," & CStr(rsRdv!NR) & ")"
End If
b = rsRdv.Bookmark
rsRdv.FindFirst "(NR Not In " & l2 & ") and HoraireDebut>=" & FormatDateUS(HF)
Do Until rsRdv.NoMatch
rsRdv.Edit
rsRdv!Id = i
rsRdv.Update
l1 = l1 & "(" & CStr(rsRdv!NR) & ")"
l2 = Left(l2, Len(l2) - 1) & "," & CStr(rsRdv!NR) & ")"
HF = rsRdv!horairefin
rsRdv.FindNext "(NR Not In " & l2 & ") and HoraireDebut>=" & FormatDateUS(HF)
Loop
rsRdv.Bookmark = b
rsRdv.MoveNext
Do While Not (rsRdv.EOF)
If InStr(l1, "(" & CStr(rsRdv!NR) & ")") = 0 Then
Exit Do
End If
rsRdv.MoveNext
Loop
i = i + 1 ' Prochaine colonne
Loop
Nb = i - 1
rsRdv.MoveFirst
Do Until rsRdv.EOF
rsRdv.Edit
rsRdv!Nb = Nb
rsRdv.Update
rsRdv.MoveNext
Loop
rsRdv.Close
Set rsRdv = Nothing
Set Db = Nothing
End Sub |
et, enfin, celui-la :
Code :
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
| Public Sub ListerRdv(rsRdv As DAO.Recordset, LstNR As String, HD As Date, HF As Date)
Dim b As Variant
Dim DateD As Date, DateF As Date
MsgBox NR
rsRdv.FindFirst "(NR Not In " & LstNR & ") And HoraireDebut<" & FormatDateUS(HF) & " And HoraireFin>" & FormatDateUS(HD)
Do Until rsRdv.NoMatch
b = rsRdv.Bookmark
LstNR = Left(LstNR, Len(LstNR) - 1) & "," & CStr(rsRdv!NR) & ")"
If (rsRdv!HoraireDebut < HD) Then
DateD = rsRdv!HoraireDebut
DateF = HD
ListerRdv rsRdv, LstNR, DateD, DateF
End If
rsRdv.Bookmark = b
If (rsRdv!horairefin > HF) Then
DateD = HF
DateF = rsRdv!horairefin
ListerRdv rsRdv, LstNR, DateD, DateF
End If
rsRdv.Bookmark = b
rsRdv.FindNext "(NR Not In " & LstNR & ") And HoraireDebut<" & FormatDateUS(HF) & " And HoraireFin>" & FormatDateUS(HD)
Loop
End Sub |
Je ne sais pas si ce sera plus clair ... si jamais user passe dans les parages ... 
|
26/04/2011, 16h39
boite de dialogue (inutile) vierge avec un bouton ok
00
