formulaire qui s'ouvre, se ferme et .. se réouvre

**emulamateur** · 18/08/2012, 11h34

Bjr,

J'utilise un formulaire en mode "ajout".

J'entre mes données et lorsque je les valide, l'enregistrement s'effectue, le formulaire se ferme ... puis se rouvre, à nouveau, en mode ajout ...

Voici le code utilisé (il n'est pas de moi ...) :

Code :

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
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
344
DoCmd.SetWarnings False
On Error Resume Next
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.Texte217 & " " & Me.Texte219 '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) & Texte197 & Chr(34) & ""
  'and [subject]= " & Chr(34) & Texte197 & Chr(34) & "
 '   MsgBox Filtre
    Set currentAppointment = myAppointments.Find(filtre)
    While TypeName(currentAppointment) <> "Nothing"
 
        MsgBox currentAppointment.subject & " " & currentAppointment.Duration & " " & currentAppointment.Body
'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_rendezvousajform4!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_rendezvousajform4!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
DoCmd.SetWarnings (True)
End Sub

Cdt

**Dolphy35** · 18/08/2012, 14h03

Bonjour,

Si tu nous explique pas ton problème on ne pourra pas t'aider.

@+

**emulamateur** · 18/08/2012, 14h08

Je pensais avoir été clair

En fait, lorsque je lance le code "ci-dessus" ... l'enregistrement s'ajoute dans la table "t_rendezvous" et le formulaire se ferme (tout fonctionne jusque là) ...

Mais, alors que rien ne devrait plus se passer, le formulaire se "rouvre" ... mais il est vierge de tout nouvel enregistrement ... j'en déduis qu'il est en mode ajout ...

Je clique alors sur le bouton "undo" (que j'ai créé et qui est présent dans le formulaire) et le formulaire se ferme ...

Bref, tout ceci n'est pas très "orthodoxe" ...

Je n'ai aucun message d'erreur, ni "plantage" ... sauf que le formulaire s'ouvre à nouveau ...

**User** · 18/08/2012, 14h31

Salut,

A quoi servent les :

Code :

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

SendKeys "{ENTER}", False

A+

**emulamateur** · 18/08/2012, 16h16

@USER

Ben justement ..

je viens de me rendre compte qu'ils ne servaient à rien ...

Je les ai supprimés et "miracle" ... le bug a disparu.

Il semblerait que dans le cadre du process, le déclencheur "gardait" le focus et le sendkey "relançait" le machin ...

Merci ! Merci à tous ...

Une balise "résolu"

formulaire qui s'ouvre, se ferme et .. se réouvre

IHM

Discussions similaires

Partager

Partager