Double clic et recherche multicriteres

**Raphael39** · 17/08/2006, 16h36

Bonjour,

J'ai une base de donnée contenant plusieurs tables et dans laquelle j'ai un formulaire de recherche multicriteres disposant d'une zone d'affichage du resultats.

Voici le code du formulaire : Recherche

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
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
 
Option Compare Database
Option Explicit
 
Private Sub cbo_champ_AfterUpdate()
If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
   Exit Sub     ' l'un des champs est vide
End If
 
' initialise les étiquettes de l'opérateur
Me.lbl_Etiq1.Visible = True
Me.lbl_Etiq2.Visible = True
Me.lbl_Etiq3.Visible = True
Me.lbl_Etiq4.Visible = True
Me.lbl_Etiq5.Visible = True
Me.opt_Ope1.Visible = True
Me.opt_Ope2.Visible = True
Me.opt_Ope3.Visible = True
Me.opt_Ope4.Visible = True
Me.opt_Ope5.Visible = True
Me.txt_critere.Visible = True
 
 
Select Case lf_GetTypeField(Me.cbo_table, Me.cbo_champ)  ' pour trouver le type du champs
 
 
    Case Is = dbBoolean     ' Booléen
         Me.lbl_TypeChamp.Caption = "Oui/Non"
         Me.lbl_Etiq1.Caption = "Oui"
         Me.lbl_Etiq2.Caption = "Non"
         Me.lbl_Etiq3.Caption = "Est Null"
         Me.lbl_Etiq4.Caption = "N'est pas Null"
         Me.lbl_Etiq5.Visible = False
         Me.opt_Ope5.Visible = False
         Me.txt_critere.Visible = False   ' pas de critere
 
    Case dbByte To dbBinary, dbLongBinary, dbGUID To dbVarBinary, dbNumeric To dbTimeStamp   ' Numériques / date
         Me.lbl_TypeChamp.Caption = "Numérique"
         Me.lbl_Etiq1.Caption = "Etre égale ="
         Me.lbl_Etiq2.Caption = "Etre supérieure >="
         Me.lbl_Etiq3.Caption = "Etre inférieure <="
         Me.lbl_Etiq4.Caption = "Etre différente <>"
         Me.lbl_Etiq5.Visible = False
         Me.opt_Ope5.Visible = False
 
    Case dbText, dbMemo, dbChar ' texte / mémo
         Me.lbl_TypeChamp.Caption = "Texte"
         Me.lbl_Etiq1.Caption = "Etre strictement identique"
         Me.lbl_Etiq2.Caption = "Commencer par la valeur"
         Me.lbl_Etiq3.Caption = "Contenir la valeur"
         Me.lbl_Etiq4.Caption = "Finir par la valeur"
         Me.lbl_Etiq5.Caption = "Pas contenir la valeur"
 
     Case Else
         Me.lbl_TypeChamp.Caption = "Cas non prévu " & lf_GetTypeField(Me.cbo_table, Me.cbo_champ)
 
End Select
End Sub
 
Private Sub cbo_Query_AfterUpdate()
Function lf_GetQueryList()
' renseigne la table tbl_TemplstQry
 
Dim qrs As QueryDefs
Dim rst As Recordset
 
Dim strSql As String
Dim i As Integer
 
' efface la table temporaire
DoCmd.SetWarnings False
strSql = "Delete tbl_TempLstQry.*"
strSql = strSql + " FROM tbl_TempLstQry;"
DoCmd.RunSQL strSql
 
' rempli    la table temporaire
Set qrs = CurrentDb.QueryDefs
Set rst = CurrentDb.OpenRecordset("tbl_TempLstQry")
 
For i = 0 To qrs.Count - 1
    ' Ne prend que le query USER_....
    If qrs(i).Name Like "USER_*" Then
       rst.AddNew
       rst.Fields(0) = qrs(i).Name
       rst.Update
    End If
Next
 
lf_GetQueryList = rst.RecordCount
 
rst.Close
Set rst = Nothing
Set qrs = Nothing
DoCmd.SetWarnings True
 
End Function
 
 
Private Sub cbo_table_AfterUpdate()
Me.cbo_champ.RowSource = Me.cbo_table.Value
    Me.cbo_champ.Requery
Me.lst_champs.RowSource = Me.cbo_table.Value
    Me.lst_champs.Requery
End Sub
 
Private Sub cmd_LoadSQL_Click()
' charge la query
Dim strQuery As String
 
' élimine de cr lf (version 2000 et  +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
 
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
'     lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
'     strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
 
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
 
Private Sub cmd_recherche_Click()
Dim strTable As String, strField As String, strCriteria As String, strSql As String
    Dim Criter As Variant
    If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
      MsgBox "Vous devez renseigner la table et le champ pour effectuer une recherche !", vbExclamation + vbOKOnly, "Recherche"
      Exit Sub
   End If
 
Dim intTypChamp As Integer
Dim intOpeChamp As Integer
 
    strTable = Me.cbo_table         ' recupère le nom de la table
    strField = Me.cbo_champ         ' recupère le nom du champ
    intTypChamp = lf_GetTypeField(strTable, strField)  ' pour trouver le type du champs ...
intOpeChamp = Me.opt_Recherche
 
Select Case intTypChamp
 
       Case dbBoolean                       ' bool
            Select Case intOpeChamp
               Case 1   ' oui
                   strCriteria = strTable & "." & strField & "=-1"
               Case 2   ' non
                   strCriteria = strTable & "." & strField & "=0"
               Case 3
                   strCriteria = "ISNULL(" & strTable & "." & strField & ")"
               Case 4
                   strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
             End Select
 
       Case dbByte To dbBinary, dbLongBinary, dbBigInt To dbVarBinary, dbNumeric To dbTimeStamp
            ' traite les numeriques
            If Not IsNull(Me.txt_critere) Then   ' si le null n'est pas la valeur à traiter
               strCriteria = Me.txt_critere
               ' traite la virgule si elle existe
               If InStr(1, Me.txt_critere, ",") > 0 Then strCriteria = Replace(Me.txt_critere, ",", ".", 1)
 
               '----------------------- pour les versions antérieure à la 2000
               'If InStr(1, Me.txt_critere, ",") > 0 Then _
               ' strCriteria = Left(Me.txt_critere, InStr(1, Me.txt_critere, ",") - 1) _
               ' & "." & Right(Me.txt_critere, InStr(1, Me.txt_critere, ","))
               '--------------------------------------------------------------
 
               ' type champ = date
               If intTypChamp = dbDate And IsDate(Me.txt_critere) Then strCriteria = "#" & Me.txt_critere & "#"
 
               ' rajoute les dièses
             End If
 
             Select Case intOpeChamp                    ' numerique, date
                  Case 1 ' =
                       If IsNull(Me.txt_critere) Then
                          strCriteria = "ISNULL(" & strTable & "." & strField & ")"
                       Else
                          strCriteria = strTable & "." & strField & "=" & strCriteria
                       End If
                  Case 2 ' >=
                       strCriteria = strTable & "." & strField & ">=" & strCriteria
 
                  Case 3 ' <=
                       strCriteria = strTable & "." & strField & "<=" & strCriteria
 
                  Case 4 '<>
                       If IsNull(Me.txt_critere) Then
                          strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
                       Else
                          strCriteria = strTable & "." & strField & "<>" & strCriteria
                       End If
                        End Select
 
Case dbText, dbMemo, dbChar                      ' texte
            Select Case intOpeChamp
                Case 1 ' strictement egal
                    If IsNull(Me.txt_critere) Then
                       strCriteria = "ISNULL(" & strTable & "." & strField & ")"
                    Else
                       strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & """"
                    End If
                Case 2 ' commence par
                    strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & "*"""
                Case 3 ' contient
                    strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & "*"""
                Case 4 ' fini par
                    strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & """"
                Case 5 ' ne contient pas
                    If IsNull(Me.txt_critere) Then
                       strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
                    Else
                       strCriteria = "NOT " & strTable & "." & strField & " Like """ & Me.txt_critere & """"
                    End If
            End Select
            Case Else
            MsgBox "Cas non prévu."
            Exit Sub
   End Select
   ' debut de selection des champs
    Dim strChamps As String
    Dim entCurrLigne As Integer
    For entCurrLigne = 0 To Me.lst_champs.ListCount - 1
        If Me.lst_champs.Selected(entCurrLigne) Then
            strChamps = strChamps & "[" & Me.lst_champs.Column(0, entCurrLigne) & "], "
        End If
    Next entCurrLigne
 
    If Len(strChamps) = 0 Then
       strChamps = strTable & ".*"
    Else
       strChamps = Left(strChamps, Len(strChamps) - 2)
    End If
' fin de selection des champs
 
' construit la requête sql
       If Me.Opt_RechCourante And Not Len(Me.lst_resultat.RowSource) = 0 Then
   If Not Me.lst_resultat.RowSource Like "*FROM " & strTable & "*" Then
      MsgBox "La recherche précédente ne porte pas sur la même table que la recherche actuelle.", vbExclamation + vbOKOnly, "Erreur"
      Exit Sub
   End If
    strSql = Left(Me.lst_resultat.RowSource, Len(Me.lst_resultat.RowSource) - 3)
    strSql = strSql & " " & Me.cbo_operateur & " " & strCriteria & "));"
 Else
   ' construit la rq sql
 ' construit la rq sql
   strSql = "SELECT DISTINCTROW " & strChamps
   strSql = strSql + " FROM " & strTable
   strSql = strSql + " WHERE ((" & strCriteria & "));"
End If
 
 
    Me.lst_resultat.RowSource = strSql  ' affecte sql a lst_Resultat
    Me.lst_resultat.Requery             ' recalcule la liste
    varqry = strSql
Me.txt_ChaineSQL.Value = strSql           ' affiche le code
 
Me.lbl_nbRecord.Caption = IIf(Me.lst_resultat.ListCount _
        <= 1, 0, Me.lst_resultat.ListCount - 1) & "/" & _
        DCount(Me.cbo_champ, Me.cbo_table)
End Sub
 
Private Sub cmd_saveSQL_Click()
' controle d'existance
If IsNull(Me.txt_ChaineSQL) Then    ' chaine vide
   MsgBox "La chaine SQL est vide. Sauvegarde inutile.", vbExclamation + vbOKOnly, "erreur"
   Exit Sub
End If
 
Dim strQuery As String
 
' demande le nom de la nouvelle query
strQuery = "USER_" & InputBox("Insérez le nom de la requête à créer (245 caractères max.):" _
            & vbCrLf & "Ce nom sera précédé de USER_ .", "Nom de requête")
' vérifie la non présence
If IsNull(DLookup("Nom", "tbl_TempLstQry", "Nom=""" & strQuery & """")) Then
   ' sauve la query
   CurrentDb.CreateQueryDef strQuery, Me.txt_ChaineSQL
   lf_GetQueryList 'alimente la table pour cbo_query
   Me.cbo_Query.Requery
   MsgBox "Sauvegarde de " & strQuery & " effectuée.", vbInformation + vbOKOnly, "information"
Else
   MsgBox "Ce nom de requête existe déjà.", vbExclamation + vbOKOnly, "Erreur"
End If
End Sub
 
Private Sub cmd_suppSQL_Click()
' charge la query
Dim strQuery As String
 
' élimine de cr lf (version 2000 et  +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
 
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
'     lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
'     strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
 
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
 
Private Sub cmd_testSQL_Click()
' visualise la query
If IsNull(Me.txt_ChaineSQL) Then Exit Sub     ' pas de chaine SQL
Me.lst_resultat.RowSource = Me.txt_ChaineSQL  ' Affecte la chaine pour visualisation
Me.lst_resultat.Requery                       ' reffraichit la liste
End Sub
 
Private Sub Form_Open(Cancel As Integer)
' crée la liste des tables
 If lf_GetTableList() = 0 Then
   MsgBox "Pas de tables dans cette application .", vbInformation + vbOKOnly, "Erreur"
   Cancel = True
End If
lf_GetQueryList       'alimente la table pour cbo_query
Me.cbo_Query.Requery  'raffraichit la liste
 
End Sub
 
Private Sub Form_Resize()
Opt_RechCourante_Click    'cache la zone liste et l'étiquette
End Sub
 
Private Sub lst_resultat_DblClick(Cancel As Integer)
Dim rst As Recordset
Dim strCriteria As String
 
Set rst = CurrentDb.OpenRecordset("tbl_TempLstFrm", dbOpenSnapshot)
' recherche les informations de la table
rst.FindFirst ("Table='" & Me.cbo_table & "'")
 
If rst.NoMatch Then     ' non trouvé
   MsgBox "Cette table ne possède pas de formulaire. Veuillez renseigner la table des paramètres.", _
          vbCritical + vbOKOnly, "formulaire de Recherche"
   Exit Sub
Else                    ' trouvé
   If lf_GetTypeField(Me.cbo_table, rst.Fields("Champ")) = dbText Then  'la clef est Texte
      strCriteria = rst.Fields("Champ") & "='" & Me.lst_resultat & "'"
   Else                                                                 'la clef est numérique
      strCriteria = rst.Fields("Champ") & "=" & Me.lst_resultat
   End If
   DoCmd.OpenForm rst.Fields("Formulaire"), acNormal, , strCriteria
End If
 
End Sub
 
Private Sub Btn_Click()
On Error GoTo Err_Btn_Click
 
    Dim stDocName As String
    DoCmd.Minimize
    stDocName = "E_Recherche"
    DoCmd.OpenReport stDocName, acPreview
 
Exit_Btn_Click:
    Exit Sub
 
Err_Btn_Click:
    MsgBox Err.Description
    Resume Exit_Btn_Click
 
End Sub
Private Sub Commande40_Click()
On Error GoTo Err_Commande40_Click
 
 
    DoCmd.GoToRecord , , acLast
 
Exit_Commande40_Click:
    Exit Sub
 
Err_Commande40_Click:
    MsgBox Err.Description
    Resume Exit_Commande40_Click
 
End Sub
Private Sub Commande47_Click()
On Error GoTo Err_Commande47_Click
 
 
    DoCmd.GoToRecord , , acLast
 
Exit_Commande47_Click:
    Exit Sub
 
Err_Commande47_Click:
    MsgBox Err.Description
    Resume Exit_Commande47_Click
 
End Sub
 
Private Sub Opt_RechCourante_Click()
If Me.Opt_RechCourante = True Then ' recherche courante activée
       Me.cbo_operateur.Visible = True
       Me.lbl_operateur.Visible = True
    Else
       Me.cbo_operateur.Visible = False
       Me.lbl_operateur.Visible = False
    End If
End Sub

Voici le code du module recherche

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
 
Option Compare Database
Option Explicit
 
Function lf_GetTypeField(lfNameTbl As String, lfNameFld As String)
' Renvoie le numéro du type du champ
'lfNameTbl = nom de la table
'lfNameFld = nom du champ
 
    Dim dbs As Database             ' Objet de la base
    Dim tbl As TableDef             ' Objet de définition de table
 
    Set dbs = CurrentDb             ' ouvre la base courante
    Set tbl = dbs.TableDefs(lfNameTbl)  ' ouvre la définition table
 
    lf_GetTypeField = tbl.Fields(lfNameFld).Type  ' renvoie le type de champ
    Set tbl = Nothing               ' libération des objets
    Set dbs = Nothing
End Function
 
Function lf_GetTableList()
' renseigne la table tbl_TemplstTbl
 
Dim qrs As TableDefs
Dim rst As DAO.Recordset
 
Dim strSql As String
Dim i As Integer, j As Integer
 
' efface la table temporaire
DoCmd.SetWarnings False
strSql = "Delete tbl_TempLstTbl.*"
strSql = strSql + " FROM tbl_TempLstTbl;"
DoCmd.RunSQL strSql
 
' rempli    la table temporaire
Set qrs = CurrentDb.TableDefs
Set rst = CurrentDb.OpenRecordset("tbl_TempLstTbl")
 
For i = 0 To qrs.Count - 1
    ' ecarte les tables temp et systeme
    If Not (qrs(i).Name Like "*Temp*") And Not (qrs(i).Name Like "Msys*") And Not (qrs(i).Name Like "*tmp*") Then
       rst.AddNew
       rst.Fields(0) = qrs(i).Name
       rst.Update
    End If
Next
lf_GetTableList = rst.RecordCount
 
rst.Close
Set rst = Nothing
Set qrs = Nothing
DoCmd.SetWarnings True
End Function

Quand je double clique sur l'un des enregistrement affiches dans la zone resultat du formulaire on doit voir apparaitre un formulaire (ayant comme modele le formulaire auto correspondant a la table concernees par la recherche or quand je clique sur le dit enregistrement j'ai une fenetre VB qui s'ouvre et affiche " Erreur d'execution '3265' Element non retrouve dans la collection" et en lancant le debogeur on voit le module recherche d'affiche et la ligne en surligne jaune :

lf_GetTypeField = tbl.Fields(lfNameFld).Type ' renvoie le type de champ

Ce qui est desolant c'est que cela marche bien pour la table Employes

Quelqu'un aurait-il un conseil ou/et une idée ? SVP Merci
P.S. : Tous mes formulaires auto sont nome : frmAutoEmployes ; frmAutoFilm et j'ai bien une table : tbl_TempLstFrm contenat les champs : Table ; Formulaire ; Champ

Raphaël

**LedZeppII** · 18/08/2006, 20h59

Bonsoir,

Une idée.
Je pense que le nom du champ est mal orthographié dans ta table tbl_TempLstFrm contenant (si j'ai bien suivi)
un nom de table, un nom de formulaire, et un nom de champ.

Le message d'erreur dit que le champ (lfNameFld) n'existe pas dans la table
lfNameTbl (Me.cbo_table).

Par Exemple si tu as ajouté des crochets droits, ça ne marche pas parce que
tbl.Fields("le champ") et tbl.Fields("[le champ]") sont deux éléments distincts dans une collection.
Ou sinon il s'agit d'une simple faute de frappe ou d'accent.

Bon courage

**Raphael39** · 19/08/2006, 21h57

Bonjour,

Merci pour cette reponse, je suis en week end en famille, je regarde cela mardi matin quand je suis de retour au bureau.

Merci encore, bon week end
@+
Raphael

**loufab** · 21/08/2006, 09h59

Bonjour,

Il serait intéressant de voir le nom du champ qui pose problème.
Dans le cas ou il contient des espaces et autres caractères rendant obligatoire les [] il te faut intégré les modifications décritent dans la 2ème partie de mon tuto sur ce module de recherche. (1er Chapitre)

http://loufab.developpez.com/recursivite2

Cordialement,

**Raphael39** · 22/08/2006, 12h37

Bonjour,

Je viens de verifie et je ne vois pas de caracteres "spéciaux" dans le nom des champs et/ou tables.

par contre je vous signale que quand j'ouvre la dite base de donnée j'ai une fenetre qui s'ouvre avec :

Votre base de donnees ou projet SuiviMateriel contient une reference incomplete ou rompue au fichier 'msadox.dll' version 2.8
Pour le fonctionnement correcte de votre base de données ou projet vous devez rectifier cette reference.

et une touche ok

Pour lancer la base je clique sur Ok et cela lance la dite base. y a t il un rapport ??

Je peux envoyer par mail (piece jointe 2Mo) ma base a qui veut car la je ne comprend rien de rien et cela devient problematique pour mon projet.

**loufab** · 22/08/2006, 13h09

Voir du coté des références :

le module de recherche utilise DAO 3.6 apparement le lien ADOx est rompu.

A voir.

**Raphael39** · 24/08/2006, 12h08

Bonjour,

J'ai ouvert Access, puis VB et dans le menu 'outil' le sous menu 'reference' et là j'ai fait parcourir pour retrouver le fichier dans C:/... puis clicque sur Ok comme rien ne se passait j'ai decocher la case Manque liaison DAO .... Depuis, j'arrive a ouvrir ma base de donnees sans voir apparaitre le fenetre concernant se probleme (signale dans post precedent).

Mais j'ai toujours mon probleme signale dans le post du 17/08/2006 16h36 de cette discussion. J'ai essayer d'importer une nouvelle table ( avec bien sur creation du formulaire automatique et insertion dans la table des formulaire auto) de faire une recherche multicriteres dessus cela marche jusqu'au moment ou je double clique sur l'un des resultats pour voir apparaitre le formulaire automatique correspondant au resultat. J'obtiens le meme message d'erreur que dans le post 17/08/2006 16h36.

Quelqu'un aurait-il une idee ?? SVP Merci
Quelqu'un accepterait-il de regarde ma basse de données ? SVP Merci

Raphael

**Raphael39** · 26/08/2006, 12h21

Bonjour,

Merci a tous pour votre aide et plus particulierement a LedZeppII.

Je suis en cours de réalisation d’une base de données avec un formulaire de recherche multicritères mais je n’arrive pas à encoder de manière satisfaisante. Je bloque sur le code de mon bouton d’impression. Quelqu’un pourrait-il me donner des conseils et/ou idées et/ou une correction de mon code ? SVP Merci
Raphael

Voici les détails de mon projet :
J’ai une base de données contenant plusieurs tables de données et plusieurs tables « temporaires » (qui servent au fonctionnement de la base) dont l’une qui s’appelle : tbl_TempLstE qui contient les champs suivants :
Table
Etat
Champ

Cette base comprend, également, un formulaire de rechercher-multicritères. Sur celui-ci, j’ai un bouton impression (btn) qui est destiné a ouvrir l’état correspond a la recherche (basé sur la table utilisée et sur les critères sélectionnés lors de celle-ci) et qui ne doit contenir que les enregistrements répondant a la recherche effectuée. Les résultats de la recherche s’affichent dans lst_resultat

Code FUTUR du Bouton « Impression Résultats » :

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
 
Private Sub Btn_Click()
On Error GoTo Err_Btn_Click
Dim rst As Recordset
Dim strCriteria As String
 
Set rst = CurrentDb.OpenRecordset("tbl_TempLstE", dbOpenSnapshot)
' recherche les informations de la table
rst.FindFirst ("Table='" & Me.cbo_table & "'")
 
If rst.NoMatch Then     ' non trouvé
   MsgBox "Cette table ne possède pas d’Etat. Veuillez renseigner la table : tbl_TempLstE .", _
          vbCritical + vbOKOnly, "formulaire de Recherche"
   Exit Sub
Else                    ' trouvé
   If lf_GetTypeField(Me.cbo_table, rst.Fields("Champ")) = dbText Then  'la clef est Texte
      strCriteria = rst.Fields("Champ") & "='" & Me.lst_resultat & "'"
   Else                                                                 'la clef est numérique
      strCriteria = rst.Fields("Champ") & "=" & Me.lst_resultat
   End If
   DoCmd.OpenForm rst.Fields("Etat"), acNormal, , strCriteria
End If
 
    Dim stDocName As String
    DoCmd.Minimize
    stDocName = "E_AutoEmployes"
    DoCmd.OpenReport stDocName, acPreview
 
Exit_Btn_Click:
    Exit Sub
 
Err_Btn_Click:
    MsgBox Err.Description
    Resume Exit_Btn_Click
 
End Sub

SVP Merci
Raphael

**LedZeppII** · 26/08/2006, 16h34

Bonjour Raphaël,

Il te faut extraire la condion WHERE du SQL source de la liste résultat.

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
Dim rst As Recordset
Dim stDocName As String
Dim strWhere As String, strQry As String, p As Integer

On Error GoTo Err_Btn_Click

    Set rst = CurrentDb.OpenRecordset("tbl_TempLstE", dbOpenSnapshot)
    ' recherche les informations de la table
    rst.FindFirst ("Table='" & Me.cbo_table & "'")
    
    If rst.NoMatch Then     ' non trouvé
       MsgBox "Cette table ne possède pas d’Etat. Veuillez renseigner la table : tbl_TempLstE .", _
              vbCritical + vbOKOnly, "formulaire de Recherche"
       Exit Sub
    End If

    stDocName = rst.Fields("Etat")
    ' Extrait condition WHERE du source SQL
    ' de la liste résultat
    strQry = Me.lst_resultat.RowSource
    p = InStr(1, strQry, "WHERE ", vbTextCompare)
    If p = 0 Then GoTo Exit_Btn_Click

    strWhere = Mid(strQry, p + 6, Len(strQry) - p - 5)
    strWhere = Trim(strWhere)
    If Right(strWhere, 1) = ";" Then _
             strWhere = Left(strWhere, Len(strWhere) - 1)

    DoCmd.Minimize
    DoCmd.OpenReport stDocName, acPreview, , strWhere

Exit_Btn_Click:
    Exit Sub

Err_Btn_Click:
    MsgBox Err.Description
    Resume Exit_Btn_Click

Bonne continuation

**Raphael39** · 27/08/2006, 09h27

Bonjour,

De retour chez moi, je viens d’insérer ton code dans le VB de ma base de données.

Dans le formulaire de recherche multicritères, quand j’affiche mes résultats dans la fenêtre, j’ai une fenêtre VB qui s’affiche avec :

Erreur de compilation
End Sub attendu

Dans mon code :

Code :

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

1
2
 
    Resume Exit_Btn_Click

Est surligne en bleu

Et dans le code :

Code :

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

1
2
 
Private Sub Btn_Click()

Est surligne en jaune.

Voici l’ensemble de mon code de mon formulaire multicritères :

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
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
 
Option Compare Database
Option Explicit
 
Private Sub cbo_champ_AfterUpdate()
If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
   Exit Sub     ' l'un des champs est vide
End If
 
' initialise les étiquettes de l'opérateur
Me.lbl_Etiq1.Visible = True
Me.lbl_Etiq2.Visible = True
Me.lbl_Etiq3.Visible = True
Me.lbl_Etiq4.Visible = True
Me.lbl_Etiq5.Visible = True
Me.opt_Ope1.Visible = True
Me.opt_Ope2.Visible = True
Me.opt_Ope3.Visible = True
Me.opt_Ope4.Visible = True
Me.opt_Ope5.Visible = True
Me.txt_critere.Visible = True
 
 
Select Case lf_GetTypeField(Me.cbo_table, Me.cbo_champ)  ' pour trouver le type du champs
 
 
    Case Is = dbBoolean     ' Booléen
         Me.lbl_TypeChamp.Caption = "Oui/Non"
         Me.lbl_Etiq1.Caption = "Oui"
         Me.lbl_Etiq2.Caption = "Non"
         Me.lbl_Etiq3.Caption = "Est Null"
         Me.lbl_Etiq4.Caption = "N'est pas Null"
         Me.lbl_Etiq5.Visible = False
         Me.opt_Ope5.Visible = False
         Me.txt_critere.Visible = False   ' pas de critere
 
    Case dbByte To dbBinary, dbLongBinary, dbGUID To dbVarBinary, dbNumeric To dbTimeStamp   ' Numériques / date
         Me.lbl_TypeChamp.Caption = "Numérique"
         Me.lbl_Etiq1.Caption = "Etre égale ="
         Me.lbl_Etiq2.Caption = "Etre supérieure >="
         Me.lbl_Etiq3.Caption = "Etre inférieure <="
         Me.lbl_Etiq4.Caption = "Etre différente <>"
         Me.lbl_Etiq5.Visible = False
         Me.opt_Ope5.Visible = False
 
    Case dbText, dbMemo, dbChar ' texte / mémo
         Me.lbl_TypeChamp.Caption = "Texte"
         Me.lbl_Etiq1.Caption = "Etre strictement identique"
         Me.lbl_Etiq2.Caption = "Commencer par la valeur"
         Me.lbl_Etiq3.Caption = "Contenir la valeur"
         Me.lbl_Etiq4.Caption = "Finir par la valeur"
         Me.lbl_Etiq5.Caption = "Pas contenir la valeur"
 
     Case Else
         Me.lbl_TypeChamp.Caption = "Cas non prévu " & lf_GetTypeField(Me.cbo_table, Me.cbo_champ)
 
End Select
End Sub
 
Private Sub cbo_Query_AfterUpdate()
Function lf_GetQueryList()
' renseigne la table tbl_TemplstQry
 
Dim qrs As QueryDefs
Dim rst As Recordset
 
Dim strSql As String
Dim i As Integer
 
' efface la table temporaire
DoCmd.SetWarnings False
strSql = "Delete tbl_TempLstQry.*"
strSql = strSql + " FROM tbl_TempLstQry;"
DoCmd.RunSQL strSql
 
' rempli    la table temporaire
Set qrs = CurrentDb.QueryDefs
Set rst = CurrentDb.OpenRecordset("tbl_TempLstQry")
 
For i = 0 To qrs.Count - 1
    ' Ne prend que le query USER_....
    If qrs(i).Name Like "USER_*" Then
       rst.AddNew
       rst.Fields(0) = qrs(i).Name
       rst.Update
    End If
Next
 
lf_GetQueryList = rst.RecordCount
 
rst.Close
Set rst = Nothing
Set qrs = Nothing
DoCmd.SetWarnings True
 
End Function
 
 
Private Sub cbo_table_AfterUpdate()
Me.cbo_champ.RowSource = Me.cbo_table.Value
    Me.cbo_champ.Requery
Me.cbo_champ.Value = Null
Me.lst_champs.RowSource = Me.cbo_table.Value
    Me.lst_champs.Requery
End Sub
 
Private Sub cmd_LoadSQL_Click()
' charge la query
Dim strQuery As String
 
' élimine de cr lf (version 2000 et  +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
 
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
'     lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
'     strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
 
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
 
Private Sub cmd_recherche_Click()
Dim strTable As String, strField As String, strCriteria As String, strSql As String
    Dim Criter As Variant
    If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
      MsgBox "Vous devez renseigner la table et le champ pour effectuer une recherche !", vbExclamation + vbOKOnly, "Recherche"
      Exit Sub
   End If
 
Dim intTypChamp As Integer
Dim intOpeChamp As Integer
 
    strTable = Me.cbo_table         ' recupère le nom de la table
    strField = Me.cbo_champ         ' recupère le nom du champ
    intTypChamp = lf_GetTypeField(strTable, strField)  ' pour trouver le type du champs ...
intOpeChamp = Me.opt_Recherche
 
Select Case intTypChamp
 
       Case dbBoolean                       ' bool
            Select Case intOpeChamp
               Case 1   ' oui
                   strCriteria = strTable & "." & strField & "=-1"
               Case 2   ' non
                   strCriteria = strTable & "." & strField & "=0"
               Case 3
                   strCriteria = "ISNULL(" & strTable & "." & strField & ")"
               Case 4
                   strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
             End Select
 
       Case dbByte To dbBinary, dbLongBinary, dbBigInt To dbVarBinary, dbNumeric To dbTimeStamp
            ' traite les numeriques
            If Not IsNull(Me.txt_critere) Then   ' si le null n'est pas la valeur à traiter
               strCriteria = Me.txt_critere
               ' traite la virgule si elle existe
               If InStr(1, Me.txt_critere, ",") > 0 Then strCriteria = Replace(Me.txt_critere, ",", ".", 1)
 
               '----------------------- pour les versions antérieure à la 2000
               'If InStr(1, Me.txt_critere, ",") > 0 Then _
               ' strCriteria = Left(Me.txt_critere, InStr(1, Me.txt_critere, ",") - 1) _
               ' & "." & Right(Me.txt_critere, InStr(1, Me.txt_critere, ","))
               '--------------------------------------------------------------
 
               ' type champ = date
               If intTypChamp = dbDate And IsDate(Me.txt_critere) Then strCriteria = "#" & Me.txt_critere & "#"
 
               ' rajoute les dièses
             End If
 
             Select Case intOpeChamp                    ' numerique, date
                  Case 1 ' =
                       If IsNull(Me.txt_critere) Then
                          strCriteria = "ISNULL(" & strTable & "." & strField & ")"
                       Else
                          strCriteria = strTable & "." & strField & "=" & strCriteria
                       End If
                  Case 2 ' >=
                       strCriteria = strTable & "." & strField & ">=" & strCriteria
 
                  Case 3 ' <=
                       strCriteria = strTable & "." & strField & "<=" & strCriteria
 
                  Case 4 '<>
                       If IsNull(Me.txt_critere) Then
                          strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
                       Else
                          strCriteria = strTable & "." & strField & "<>" & strCriteria
                       End If
                        End Select
 
Case dbText, dbMemo, dbChar                      ' texte
            Select Case intOpeChamp
                Case 1 ' strictement egal
                    If IsNull(Me.txt_critere) Then
                       strCriteria = "ISNULL(" & strTable & "." & strField & ")"
                    Else
                       strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & """"
                    End If
                Case 2 ' commence par
                    strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & "*"""
                Case 3 ' contient
                    strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & "*"""
                Case 4 ' fini par
                    strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & """"
                Case 5 ' ne contient pas
                    If IsNull(Me.txt_critere) Then
                       strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
                    Else
                       strCriteria = "NOT " & strTable & "." & strField & " Like """ & Me.txt_critere & """"
                    End If
            End Select
            Case Else
            MsgBox "Cas non prévu."
            Exit Sub
   End Select
   ' debut de selection des champs
    Dim strChamps As String
    Dim entCurrLigne As Integer
    For entCurrLigne = 0 To Me.lst_champs.ListCount - 1
        If Me.lst_champs.Selected(entCurrLigne) Then
            strChamps = strChamps & "[" & Me.lst_champs.Column(0, entCurrLigne) & "], "
        End If
    Next entCurrLigne
 
    If Len(strChamps) = 0 Then
       strChamps = strTable & ".*"
    Else
       strChamps = Left(strChamps, Len(strChamps) - 2)
    End If
' fin de selection des champs
 
' construit la requête sql
       If Me.Opt_RechCourante And Not Len(Me.lst_resultat.RowSource) = 0 Then
   If Not Me.lst_resultat.RowSource Like "*FROM " & strTable & "*" Then
      MsgBox "La recherche précédente ne porte pas sur la même table que la recherche actuelle.", vbExclamation + vbOKOnly, "Erreur"
      Exit Sub
   End If
    strSql = Left(Me.lst_resultat.RowSource, Len(Me.lst_resultat.RowSource) - 3)
    strSql = strSql & " " & Me.cbo_operateur & " " & strCriteria & "));"
 Else
   ' construit la rq sql
 ' construit la rq sql
   strSql = "SELECT DISTINCTROW " & strChamps
   strSql = strSql + " FROM " & strTable
   strSql = strSql + " WHERE ((" & strCriteria & "));"
End If
 
 
    Me.lst_resultat.RowSource = strSql  ' affecte sql a lst_Resultat
    Me.lst_resultat.Requery             ' recalcule la liste
    varqry = strSql
Me.txt_ChaineSQL.Value = strSql           ' affiche le code
 
Me.lbl_nbRecord.Caption = IIf(Me.lst_resultat.ListCount _
        <= 1, 0, Me.lst_resultat.ListCount - 1) & "/" & _
        DCount(Me.cbo_champ, Me.cbo_table)
End Sub
 
Private Sub cmd_saveSQL_Click()
' controle d'existance
If IsNull(Me.txt_ChaineSQL) Then    ' chaine vide
   MsgBox "La chaine SQL est vide. Sauvegarde inutile.", vbExclamation + vbOKOnly, "erreur"
   Exit Sub
End If
 
Dim strQuery As String
 
' demande le nom de la nouvelle query
strQuery = "USER_" & InputBox("Insérez le nom de la requête à créer (245 caractères max.):" _
            & vbCrLf & "Ce nom sera précédé de USER_ .", "Nom de requête")
' vérifie la non présence
If IsNull(DLookup("Nom", "tbl_TempLstQry", "Nom=""" & strQuery & """")) Then
   ' sauve la query
   CurrentDb.CreateQueryDef strQuery, Me.txt_ChaineSQL
   lf_GetQueryList 'alimente la table pour cbo_query
   Me.cbo_Query.Requery
   MsgBox "Sauvegarde de " & strQuery & " effectuée.", vbInformation + vbOKOnly, "information"
Else
   MsgBox "Ce nom de requête existe déjà.", vbExclamation + vbOKOnly, "Erreur"
End If
End Sub
 
Private Sub cmd_suppSQL_Click()
' charge la query
Dim strQuery As String
 
' élimine de cr lf (version 2000 et  +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
 
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
'     lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
'     strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
 
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
 
Private Sub cmd_testSQL_Click()
' visualise la query
If IsNull(Me.txt_ChaineSQL) Then Exit Sub     ' pas de chaine SQL
Me.lst_resultat.RowSource = Me.txt_ChaineSQL  ' Affecte la chaine pour visualisation
Me.lst_resultat.Requery                       ' reffraichit la liste
End Sub
 
Private Sub Form_Open(Cancel As Integer)
' crée la liste des tables
 If lf_GetTableList() = 0 Then
   MsgBox "Pas de tables dans cette application .", vbInformation + vbOKOnly, "Erreur"
   Cancel = True
End If
lf_GetQueryList       'alimente la table pour cbo_query
Me.cbo_Query.Requery  'raffraichit la liste
 
End Sub
 
Private Sub Form_Resize()
Opt_RechCourante_Click    'cache la zone liste et l'étiquette
End Sub
 
Private Sub lst_resultat_DblClick(Cancel As Integer)
Dim rst As Recordset
Dim strCriteria As String
 
Set rst = CurrentDb.OpenRecordset("tbl_TempLstFrm", dbOpenSnapshot)
' recherche les informations de la table
rst.FindFirst ("Table='" & Me.cbo_table & "'")
 
If rst.NoMatch Then     ' non trouvé
   MsgBox "Cette table ne possède pas de formulaire. Veuillez renseigner la table des paramètres.", _
          vbCritical + vbOKOnly, "formulaire de Recherche"
   Exit Sub
Else                    ' trouvé
   If lf_GetTypeField(Me.cbo_table, rst.Fields("Champ")) = dbText Then  'la clef est Texte
      strCriteria = rst.Fields("Champ") & "='" & Me.lst_resultat & "'"
   Else                                                                 'la clef est numérique
      strCriteria = rst.Fields("Champ") & "=" & Me.lst_resultat
   End If
   DoCmd.OpenForm rst.Fields("Formulaire"), acNormal, , strCriteria
End If
 
End Sub
 
Private Sub Btn_Click()
 
Dim rst As Recordset
Dim stDocName As String
Dim strWhere As String, strQry As String, p As Integer
 
On Error GoTo Err_Btn_Click
 
    Set rst = CurrentDb.OpenRecordset("tbl_TempLstE", dbOpenSnapshot)
    ' recherche les informations de la table
    rst.FindFirst ("Table='" & Me.cbo_table & "'")
 
    If rst.NoMatch Then     ' non trouvé
       MsgBox "Cette table ne possède pas d’Etat. Veuillez renseigner la table : tbl_TempLstE .", _
              vbCritical + vbOKOnly, "formulaire de Recherche"
       Exit Sub
    End If
 
    stDocName = rst.Fields("Etat")
    ' Extrait condition WHERE du source SQL
    ' de la liste résultat
    strQry = Me.lst_resultat.RowSource
    p = InStr(1, strQry, "WHERE ", vbTextCompare)
    If p = 0 Then GoTo Exit_Btn_Click
 
    strWhere = Mid(strQry, p + 6, Len(strQry) - p - 5)
    strWhere = Trim(strWhere)
    If Right(strWhere, 1) = ";" Then _
             strWhere = Left(strWhere, Len(strWhere) - 1)
 
    DoCmd.Minimize
    DoCmd.OpenReport stDocName, acPreview, , strWhere
 
Exit_Btn_Click:
    Exit Sub
 
Err_Btn_Click:
    MsgBox Err.Description
    Resume Exit_Btn_Click
Private Sub Commande40_Click()
On Error GoTo Err_Commande40_Click
 
 
    DoCmd.GoToRecord , , acLast
 
Exit_Commande40_Click:
    Exit Sub
 
Err_Commande40_Click:
    MsgBox Err.Description
    Resume Exit_Commande40_Click
 
End Sub
Private Sub Commande47_Click()
On Error GoTo Err_Commande47_Click
 
 
    DoCmd.GoToRecord , , acLast
 
Exit_Commande47_Click:
    Exit Sub
 
Err_Commande47_Click:
    MsgBox Err.Description
    Resume Exit_Commande47_Click
 
End Sub
 
Private Sub Opt_RechCourante_Click()
If Me.Opt_RechCourante = True Then ' recherche courante activée
       Me.cbo_operateur.Visible = True
       Me.lbl_operateur.Visible = True
    Else
       Me.cbo_operateur.Visible = False
       Me.lbl_operateur.Visible = False
    End If
End Sub

Quelqu’un pourrait-il me donner des conseils et/ou des remarquer et/ou m’apporter des corrections ? SVP Merci
Raphael

**LedZeppII** · 27/08/2006, 13h10

Bonjour,

Dans ton code, fais une recherche sur cbo_Query_AfterUpdate()
Tu vas tomber sur Private Sub cbo_Query_AfterUpdate()
C'est un début de corps de Sub et il manque End Sub.

Soit tu supprimes cette ligne soit tu ajoute End Sub juste en dessous.

A+

**Raphael39** · 27/08/2006, 21h04

Bonjour,

Merci pour ta réponse rapide. J’ai ajouté un : End Sub et cela fonctionne très bien.

Maintenant, je me demande si il est possible d’automatiser la « complémentation » des tables :

tbl_TempLstFrm
tbl_TempLstE

Qui contiennent respectivement les champs :

Pour : tbl_TempLstE :

Table (C’est le nom de la table) ; par exemple : Employes
Etat (C’est le nom de l’etat lié a la table) ; par exemple : E_AutoEmployes
Champ (C’est le nom du premier champ de la table) ; par exemple : CodeEmploye

Pour : tbl_TempLstFrm :

Table (C’est le nom de la table) ; par exemple : Employes
Formulaire (C’est le nom du formulaire) ; par exemple : frmAutoEmployes;
Champ (C’est le nom du premier champ de la table) ; par exemple : CodeEmploye.

Il faudrait qu’Access, n’insère dans ces deux tables que des enregistrements concernant des tables contenues dans la base de données qui ont comme caractéristique d’avoir un formulaire se nommant : frmAutoEmployes et un etat se nommant :E_AutoEmployes pour une table se nommant Employes. Si Access trouve des tables correspondant a ces caractéristiques, il complete la table : tbl_TempLstFrm et la table : tbl_TempLstE (avec autant d’enregistrements que de table répondant aux critères).

Pensez-vous cela possible ?
Si oui avez-vous de conseils, idées ?
SVP Merci
Raphaël

Voici le code de mon formulaire de recherche multicriteres :

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
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
 
Option Compare Database
Option Explicit
 
Private Sub cbo_champ_AfterUpdate()
If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
   Exit Sub     ' l'un des champs est vide
End If
 
' initialise les étiquettes de l'opérateur
Me.lbl_Etiq1.Visible = True
Me.lbl_Etiq2.Visible = True
Me.lbl_Etiq3.Visible = True
Me.lbl_Etiq4.Visible = True
Me.lbl_Etiq5.Visible = True
Me.opt_Ope1.Visible = True
Me.opt_Ope2.Visible = True
Me.opt_Ope3.Visible = True
Me.opt_Ope4.Visible = True
Me.opt_Ope5.Visible = True
Me.txt_critere.Visible = True
 
 
Select Case lf_GetTypeField(Me.cbo_table, Me.cbo_champ)  ' pour trouver le type du champs
 
 
    Case Is = dbBoolean     ' Booléen
         Me.lbl_TypeChamp.Caption = "Oui/Non"
         Me.lbl_Etiq1.Caption = "Oui"
         Me.lbl_Etiq2.Caption = "Non"
         Me.lbl_Etiq3.Caption = "Est Null"
         Me.lbl_Etiq4.Caption = "N'est pas Null"
         Me.lbl_Etiq5.Visible = False
         Me.opt_Ope5.Visible = False
         Me.txt_critere.Visible = False   ' pas de critere
 
    Case dbByte To dbBinary, dbLongBinary, dbGUID To dbVarBinary, dbNumeric To dbTimeStamp   ' Numériques / date
         Me.lbl_TypeChamp.Caption = "Numérique"
         Me.lbl_Etiq1.Caption = "Etre égale ="
         Me.lbl_Etiq2.Caption = "Etre supérieure >="
         Me.lbl_Etiq3.Caption = "Etre inférieure <="
         Me.lbl_Etiq4.Caption = "Etre différente <>"
         Me.lbl_Etiq5.Visible = False
         Me.opt_Ope5.Visible = False
 
    Case dbText, dbMemo, dbChar ' texte / mémo
         Me.lbl_TypeChamp.Caption = "Texte"
         Me.lbl_Etiq1.Caption = "Etre strictement identique"
         Me.lbl_Etiq2.Caption = "Commencer par la valeur"
         Me.lbl_Etiq3.Caption = "Contenir la valeur"
         Me.lbl_Etiq4.Caption = "Finir par la valeur"
         Me.lbl_Etiq5.Caption = "Pas contenir la valeur"
 
     Case Else
         Me.lbl_TypeChamp.Caption = "Cas non prévu " & lf_GetTypeField(Me.cbo_table, Me.cbo_champ)
 
End Select
End Sub
 
Private Sub cbo_Query_AfterUpdate()
Function lf_GetQueryList()
' renseigne la table tbl_TemplstQry
 
Dim qrs As QueryDefs
Dim rst As Recordset
 
Dim strSql As String
Dim i As Integer
 
' efface la table temporaire
DoCmd.SetWarnings False
strSql = "Delete tbl_TempLstQry.*"
strSql = strSql + " FROM tbl_TempLstQry;"
DoCmd.RunSQL strSql
 
' rempli    la table temporaire
Set qrs = CurrentDb.QueryDefs
Set rst = CurrentDb.OpenRecordset("tbl_TempLstQry")
 
For i = 0 To qrs.Count - 1
    ' Ne prend que le query USER_....
    If qrs(i).Name Like "USER_*" Then
       rst.AddNew
       rst.Fields(0) = qrs(i).Name
       rst.Update
    End If
Next
 
lf_GetQueryList = rst.RecordCount
 
rst.Close
Set rst = Nothing
Set qrs = Nothing
DoCmd.SetWarnings True
 
End Function
 
 
Private Sub cbo_table_AfterUpdate()
Me.cbo_champ.RowSource = Me.cbo_table.Value
    Me.cbo_champ.Requery
Me.cbo_champ.Value = Null
Me.lst_champs.RowSource = Me.cbo_table.Value
    Me.lst_champs.Requery
End Sub
 
Private Sub cmd_LoadSQL_Click()
' charge la query
Dim strQuery As String
 
' élimine de cr lf (version 2000 et  +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
 
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
'     lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
'     strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
 
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
 
Private Sub cmd_recherche_Click()
Dim strTable As String, strField As String, strCriteria As String, strSql As String
    Dim Criter As Variant
    If IsNull(Me.cbo_table) Or IsNull(Me.cbo_champ) Then
      MsgBox "Vous devez renseigner la table et le champ pour effectuer une recherche !", vbExclamation + vbOKOnly, "Recherche"
      Exit Sub
   End If
 
Dim intTypChamp As Integer
Dim intOpeChamp As Integer
 
    strTable = Me.cbo_table         ' recupère le nom de la table
    strField = Me.cbo_champ         ' recupère le nom du champ
    intTypChamp = lf_GetTypeField(strTable, strField)  ' pour trouver le type du champs ...
intOpeChamp = Me.opt_Recherche
 
Select Case intTypChamp
 
       Case dbBoolean                       ' bool
            Select Case intOpeChamp
               Case 1   ' oui
                   strCriteria = strTable & "." & strField & "=-1"
               Case 2   ' non
                   strCriteria = strTable & "." & strField & "=0"
               Case 3
                   strCriteria = "ISNULL(" & strTable & "." & strField & ")"
               Case 4
                   strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
             End Select
 
       Case dbByte To dbBinary, dbLongBinary, dbBigInt To dbVarBinary, dbNumeric To dbTimeStamp
            ' traite les numeriques
            If Not IsNull(Me.txt_critere) Then   ' si le null n'est pas la valeur à traiter
               strCriteria = Me.txt_critere
               ' traite la virgule si elle existe
               If InStr(1, Me.txt_critere, ",") > 0 Then strCriteria = Replace(Me.txt_critere, ",", ".", 1)
 
               '----------------------- pour les versions antérieure à la 2000
               'If InStr(1, Me.txt_critere, ",") > 0 Then _
               ' strCriteria = Left(Me.txt_critere, InStr(1, Me.txt_critere, ",") - 1) _
               ' & "." & Right(Me.txt_critere, InStr(1, Me.txt_critere, ","))
               '--------------------------------------------------------------
 
               ' type champ = date
               If intTypChamp = dbDate And IsDate(Me.txt_critere) Then strCriteria = "#" & Me.txt_critere & "#"
 
               ' rajoute les dièses
             End If
 
             Select Case intOpeChamp                    ' numerique, date
                  Case 1 ' =
                       If IsNull(Me.txt_critere) Then
                          strCriteria = "ISNULL(" & strTable & "." & strField & ")"
                       Else
                          strCriteria = strTable & "." & strField & "=" & strCriteria
                       End If
                  Case 2 ' >=
                       strCriteria = strTable & "." & strField & ">=" & strCriteria
 
                  Case 3 ' <=
                       strCriteria = strTable & "." & strField & "<=" & strCriteria
 
                  Case 4 '<>
                       If IsNull(Me.txt_critere) Then
                          strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
                       Else
                          strCriteria = strTable & "." & strField & "<>" & strCriteria
                       End If
                        End Select
 
Case dbText, dbMemo, dbChar                      ' texte
            Select Case intOpeChamp
                Case 1 ' strictement egal
                    If IsNull(Me.txt_critere) Then
                       strCriteria = "ISNULL(" & strTable & "." & strField & ")"
                    Else
                       strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & """"
                    End If
                Case 2 ' commence par
                    strCriteria = strTable & "." & strField & " Like """ & Me.txt_critere & "*"""
                Case 3 ' contient
                    strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & "*"""
                Case 4 ' fini par
                    strCriteria = strTable & "." & strField & " Like ""*" & Me.txt_critere & """"
                Case 5 ' ne contient pas
                    If IsNull(Me.txt_critere) Then
                       strCriteria = "NOT ISNULL(" & strTable & "." & strField & ")"
                    Else
                       strCriteria = "NOT " & strTable & "." & strField & " Like """ & Me.txt_critere & """"
                    End If
            End Select
            Case Else
            MsgBox "Cas non prévu."
            Exit Sub
   End Select
   ' debut de selection des champs
    Dim strChamps As String
    Dim entCurrLigne As Integer
    For entCurrLigne = 0 To Me.lst_champs.ListCount - 1
        If Me.lst_champs.Selected(entCurrLigne) Then
            strChamps = strChamps & "[" & Me.lst_champs.Column(0, entCurrLigne) & "], "
        End If
    Next entCurrLigne
 
    If Len(strChamps) = 0 Then
       strChamps = strTable & ".*"
    Else
       strChamps = Left(strChamps, Len(strChamps) - 2)
    End If
' fin de selection des champs
 
' construit la requête sql
       If Me.Opt_RechCourante And Not Len(Me.lst_resultat.RowSource) = 0 Then
   If Not Me.lst_resultat.RowSource Like "*FROM " & strTable & "*" Then
      MsgBox "La recherche précédente ne porte pas sur la même table que la recherche actuelle.", vbExclamation + vbOKOnly, "Erreur"
      Exit Sub
   End If
    strSql = Left(Me.lst_resultat.RowSource, Len(Me.lst_resultat.RowSource) - 3)
    strSql = strSql & " " & Me.cbo_operateur & " " & strCriteria & "));"
 Else
   ' construit la rq sql
 ' construit la rq sql
   strSql = "SELECT DISTINCTROW " & strChamps
   strSql = strSql + " FROM " & strTable
   strSql = strSql + " WHERE ((" & strCriteria & "));"
End If
 
 
    Me.lst_resultat.RowSource = strSql  ' affecte sql a lst_Resultat
    Me.lst_resultat.Requery             ' recalcule la liste
    varqry = strSql
Me.txt_ChaineSQL.Value = strSql           ' affiche le code
 
Me.lbl_nbRecord.Caption = IIf(Me.lst_resultat.ListCount _
        <= 1, 0, Me.lst_resultat.ListCount - 1) & "/" & _
        DCount(Me.cbo_champ, Me.cbo_table)
End Sub
 
Private Sub cmd_saveSQL_Click()
' controle d'existance
If IsNull(Me.txt_ChaineSQL) Then    ' chaine vide
   MsgBox "La chaine SQL est vide. Sauvegarde inutile.", vbExclamation + vbOKOnly, "erreur"
   Exit Sub
End If
 
Dim strQuery As String
 
' demande le nom de la nouvelle query
strQuery = "USER_" & InputBox("Insérez le nom de la requête à créer (245 caractères max.):" _
            & vbCrLf & "Ce nom sera précédé de USER_ .", "Nom de requête")
' vérifie la non présence
If IsNull(DLookup("Nom", "tbl_TempLstQry", "Nom=""" & strQuery & """")) Then
   ' sauve la query
   CurrentDb.CreateQueryDef strQuery, Me.txt_ChaineSQL
   lf_GetQueryList 'alimente la table pour cbo_query
   Me.cbo_Query.Requery
   MsgBox "Sauvegarde de " & strQuery & " effectuée.", vbInformation + vbOKOnly, "information"
Else
   MsgBox "Ce nom de requête existe déjà.", vbExclamation + vbOKOnly, "Erreur"
End If
End Sub
 
Private Sub cmd_suppSQL_Click()
' charge la query
Dim strQuery As String
 
' élimine de cr lf (version 2000 et  +)
strQuery = Replace(CurrentDb.QueryDefs(Me.cbo_Query).SQL, Chr(13) & Chr(10), " ")
 
' élimine de cr lf (toutes versions)
'strQuery = CurrentDb.QueryDefs(Me.cbo_Query).Sql
'Dim lngPos As Long
'While (InStr(1, strQuery, Chr(13) & Chr(10)) > 0)
'     lngPos = InStr(1, strQuery, Chr(13) & Chr(10))
'     strQuery = Left(strQuery, lngPos - 1) & " " & Right(strQuery, Len(strQuery) - lngPos - 1)
'Wend
 
' met la chaine dans la zone texte
Me.txt_ChaineSQL = strQuery
' met la chaine pour afficher le résultat
Me.lst_resultat.RowSource = strQuery
End Sub
 
Private Sub cmd_testSQL_Click()
' visualise la query
If IsNull(Me.txt_ChaineSQL) Then Exit Sub     ' pas de chaine SQL
Me.lst_resultat.RowSource = Me.txt_ChaineSQL  ' Affecte la chaine pour visualisation
Me.lst_resultat.Requery                       ' reffraichit la liste
End Sub
 
Private Sub Form_Open(Cancel As Integer)
' crée la liste des tables
 If lf_GetTableList() = 0 Then
   MsgBox "Pas de tables dans cette application .", vbInformation + vbOKOnly, "Erreur"
   Cancel = True
End If
lf_GetQueryList       'alimente la table pour cbo_query
Me.cbo_Query.Requery  'raffraichit la liste
 
End Sub
 
Private Sub Form_Resize()
Opt_RechCourante_Click    'cache la zone liste et l'étiquette
End Sub
 
Private Sub lst_resultat_DblClick(Cancel As Integer)
Dim rst As Recordset
Dim strCriteria As String
 
Set rst = CurrentDb.OpenRecordset("tbl_TempLstFrm", dbOpenSnapshot)
' recherche les informations de la table
rst.FindFirst ("Table='" & Me.cbo_table & "'")
 
If rst.NoMatch Then     ' non trouvé
   MsgBox "Cette table ne possède pas de formulaire. Veuillez renseigner la table des paramètres.", _
          vbCritical + vbOKOnly, "formulaire de Recherche"
   Exit Sub
Else                    ' trouvé
   If lf_GetTypeField(Me.cbo_table, rst.Fields("Champ")) = dbText Then  'la clef est Texte
      strCriteria = rst.Fields("Champ") & "='" & Me.lst_resultat & "'"
   Else                                                                 'la clef est numérique
      strCriteria = rst.Fields("Champ") & "=" & Me.lst_resultat
   End If
   DoCmd.OpenForm rst.Fields("Formulaire"), acNormal, , strCriteria
End If
 
End Sub
 
Private Sub Btn_Click()
 
Dim rst As Recordset
Dim stDocName As String
Dim strWhere As String, strQry As String, p As Integer
 
On Error GoTo Err_Btn_Click
 
    Set rst = CurrentDb.OpenRecordset("tbl_TempLstE", dbOpenSnapshot)
    ' recherche les informations de la table
    rst.FindFirst ("Table='" & Me.cbo_table & "'")
 
    If rst.NoMatch Then     ' non trouvé
       MsgBox "Cette table ne possède pas d’Etat. Veuillez renseigner la table : tbl_TempLstE .", _
              vbCritical + vbOKOnly, "formulaire de Recherche"
       Exit Sub
    End If
 
    stDocName = rst.Fields("Etat")
    ' Extrait condition WHERE du source SQL
    ' de la liste résultat
    strQry = Me.lst_resultat.RowSource
    p = InStr(1, strQry, "WHERE ", vbTextCompare)
    If p = 0 Then GoTo Exit_Btn_Click
 
    strWhere = Mid(strQry, p + 6, Len(strQry) - p - 5)
    strWhere = Trim(strWhere)
    If Right(strWhere, 1) = ";" Then _
             strWhere = Left(strWhere, Len(strWhere) - 1)
 
    DoCmd.Minimize
    DoCmd.OpenReport stDocName, acPreview, , strWhere
 
Exit_Btn_Click:
    Exit Sub
 
Err_Btn_Click:
    MsgBox Err.Description
    Resume Exit_Btn_Click
End Sub
 
Private Sub Commande40_Click()
On Error GoTo Err_Commande40_Click
 
 
    DoCmd.GoToRecord , , acLast
 
Exit_Commande40_Click:
    Exit Sub
 
Err_Commande40_Click:
    MsgBox Err.Description
    Resume Exit_Commande40_Click
 
End Sub
Private Sub Commande47_Click()
On Error GoTo Err_Commande47_Click
 
 
    DoCmd.GoToRecord , , acLast
 
Exit_Commande47_Click:
    Exit Sub
 
Err_Commande47_Click:
    MsgBox Err.Description
    Resume Exit_Commande47_Click
 
End Sub
 
Private Sub Opt_RechCourante_Click()
If Me.Opt_RechCourante = True Then ' recherche courante activée
       Me.cbo_operateur.Visible = True
       Me.lbl_operateur.Visible = True
    Else
       Me.cbo_operateur.Visible = False
       Me.lbl_operateur.Visible = False
    End If
End Sub

SVP Merci
Raphaël

**LedZeppII** · 28/08/2006, 20h28

Bonjour Raphaël,

Oui, c'est possible.
Voici un bout de code qui remplit les tables tbl_TempLstFrm et tbl_TempLstE.
Pour tbl_TempLstFrm il remplit les trois champs Formulaire,Table,Champ.
Pour tbl_TempLstE il remplit Etat, Table.

Si une entrée dans la table (pour Formulaire ou Etat) éxiste déjà il met à jour les autres champs,
sinon il ajoute un nouvel enregistrement.

A noter : il y a une ligne que l'on peut enlever qui considère que si aucun champ clé n'a été trouvé,
on prend le premier champ de la table.
Par ailleurs, si la clé est composée de plusieurs champs ça ne fonctionne pas.

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
Sub EnumAutoFrmsRpts()
Dim oAccObj As Object, db As DAO.Database, rs As DAO.Recordset
Dim tdef As DAO.TableDef, idx As DAO.Index
Dim strTblName  As String, strField As String

Set db = CurrentDb
On Error GoTo ERRH

' Formulaires frmAutoXXXXX
Set rs = db.OpenRecordset("tbl_TempLstFrm", dbOpenDynaset)
For Each oAccObj In CurrentProject.AllForms
    If oAccObj.Name Like "frmAuto*" Then
       strTblName = Mid(oAccObj.Name, 8, Len(oAccObj.Name) - 7)
       Set tdef = Nothing
       Set tdef = db.TableDefs(strTblName)
       strField = ""
       If Not tdef Is Nothing Then
            For Each idx In tdef.Indexes
                If idx.Primary = True Then
                   strField = idx.Fields(0).Name
                End If
            Next
       End If
       ' Optionel - Force champ clé à '1er Champ'
       If strField = "" Then strField = tdef.Fields(0).Name
       If strField <> "" Then
          rs.FindFirst "[Formulaire]='" & oAccObj.Name & "'"
          If rs.NoMatch Then
             rs.AddNew
             rs![Formulaire] = oAccObj.Name
          Else
             rs.Edit
          End If
          rs![Table] = strTblName
          rs![Champ] = strField
          rs.Update
       End If
    End If
Next

' Etats E_AutoXXXXX
Set rs = db.OpenRecordset("tbl_TempLstE", dbOpenDynaset)

For Each oAccObj In CurrentProject.AllReports
    If oAccObj.Name Like "E_Auto*" Then
       strTblName = Mid(oAccObj.Name, 7, Len(oAccObj.Name) - 6)
       Set tdef = Nothing
       Set tdef = db.TableDefs(strTblName)
       If Not tdef Is Nothing Then
          rs.FindFirst "[Etat]='" & oAccObj.Name & "'"
          If rs.NoMatch Then
             rs.AddNew
             rs![Etat] = oAccObj.Name
          Else
             rs.Edit
          End If
          rs![Table] = strTblName
          rs.Update
       End If
    End If
Next

ENDPROC:
db.Close
Exit Sub

ERRH:
If Err.Number = 3265 Then
   Resume Next
Else
    If MsgBox(CStr(Err.Number) & vbCrLf & vbCrLf & Err.Description, _
                  vbYesNo, "Debug ?") = vbYes Then
       Stop       ' Faire deux fois F8 pour voie la ligne fautive
       Resume
    Else
       Resume ENDPROC
    End If
End If

End Sub

Bon courage.

**Raphael39** · 29/08/2006, 11h00

Bonjour,

Merci pour ta reponse rapide. je suis en deplacement aujourd'hui, je testerais donc ton code ce soir en rentrant (je te tiendrais au courant de l'evolution du projet bien sur).

Pourrais tu me dire où placer ce code dans mon code de ma table pour qu'il se declenche a l'ouverture de celle-ci et si il faut le faire preceder dun petit code "introductif" et/ou de "fin". SVP Merci ?

Raphael

**LedZeppII** · 29/08/2006, 17h49

Bonjour,

Tu peux le mettre dans un module de code (Module1 par exemple).
Tu remplace Sub par Funtion, End Sub par End Funtion et Exit Sub par Exit Function.
Ensuite tu crée une macro nommée Autoexec dans laquelle tu mets :
Action : ExécuterCode
Nom de fonction : EnumAutoFrmsRpts
La macro Autoexec s'exécute à chaque ouverture de la base.

A+

**Raphael39** · 30/08/2006, 23h13

Bonjour,

Merci de ton aide.

J’ai essayer ton code, en l’inseran dans le module2 car j’avais deja un module1 mais cela Bug.

Quand je lance la base de données, j’ai une fenetre qui s’ouvre avec :

Impossible pour SuiviMateriel de trouver le nom ‘EnumAutoFrmsRpts’

Si je clique sur Ok j’ai une fenetre du type Fenetre : l’action à echouee

Voici le code que j’ai mis dans module2

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
 
Function EnumAutoFrmsRpts()
Dim oAccObj As Object, db As DAO.Database, rs As DAO.Recordset
Dim tdef As DAO.TableDef, idx As DAO.Index
Dim strTblName  As String, strField As String
 
Set db = CurrentDb
On Error GoTo ERRH
 
' Formulaires frmAutoXXXXX
Set rs = db.OpenRecordset("tbl_TempLstFrm", dbOpenDynaset)
For Each oAccObj In CurrentProject.AllForms
    If oAccObj.Name Like "frmAuto*" Then
       strTblName = Mid(oAccObj.Name, 8, Len(oAccObj.Name) - 7)
       Set tdef = Nothing
       Set tdef = db.TableDefs(strTblName)
       strField = ""
       If Not tdef Is Nothing Then
            For Each idx In tdef.Indexes
                If idx.Primary = True Then
                   strField = idx.Fields(0).Name
                End If
            Next
       End If
       ' Optionel - Force champ clé à '1er Champ'
       If strField = "" Then strField = tdef.Fields(0).Name
       If strField <> "" Then
          rs.FindFirst "[Formulaire]='" & oAccObj.Name & "'"
          If rs.NoMatch Then
             rs.AddNew
             rs![Formulaire] = oAccObj.Name
          Else
             rs.Edit
          End If
          rs![Table] = strTblName
          rs![Champ] = strField
          rs.Update
       End If
    End If
Next
 
' Etats E_AutoXXXXX
Set rs = db.OpenRecordset("tbl_TempLstE", dbOpenDynaset)
 
For Each oAccObj In CurrentProject.AllReports
    If oAccObj.Name Like "E_Auto*" Then
       strTblName = Mid(oAccObj.Name, 7, Len(oAccObj.Name) - 6)
       Set tdef = Nothing
       Set tdef = db.TableDefs(strTblName)
       If Not tdef Is Nothing Then
          rs.FindFirst "[Etat]='" & oAccObj.Name & "'"
          If rs.NoMatch Then
             rs.AddNew
             rs![Etat] = oAccObj.Name
          Else
             rs.Edit
          End If
          rs![Table] = strTblName
          rs.Update
       End If
    End If
Next
 
ENDPROC:
db.Close
Exit Function
 
ERRH:
If Err.Number = 3265 Then
   Resume Next
Else
    If MsgBox(CStr(Err.Number) & vbCrLf & vbCrLf & Err.Description, _
                  vbYesNo, "Debug ?") = vbYes Then
       Stop       ' Faire deux fois F8 pour voie la ligne fautive
       Resume
    Else
       Resume ENDPROC
    End If
End If
 
End Function

Et voici le code que tu m’avais envoyé et demande de changer qques lignes de codes :

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
 
Sub EnumAutoFrmsRpts()
Dim oAccObj As Object, db As DAO.Database, rs As DAO.Recordset
Dim tdef As DAO.TableDef, idx As DAO.Index
Dim strTblName  As String, strField As String
 
Set db = CurrentDb
On Error GoTo ERRH
 
' Formulaires frmAutoXXXXX
Set rs = db.OpenRecordset("tbl_TempLstFrm", dbOpenDynaset)
For Each oAccObj In CurrentProject.AllForms
    If oAccObj.Name Like "frmAuto*" Then
       strTblName = Mid(oAccObj.Name, 8, Len(oAccObj.Name) - 7)
       Set tdef = Nothing
       Set tdef = db.TableDefs(strTblName)
       strField = ""
       If Not tdef Is Nothing Then
            For Each idx In tdef.Indexes
                If idx.Primary = True Then
                   strField = idx.Fields(0).Name
                End If
            Next
       End If
       ' Optionel - Force champ clé à '1er Champ'
       If strField = "" Then strField = tdef.Fields(0).Name
       If strField <> "" Then
          rs.FindFirst "[Formulaire]='" & oAccObj.Name & "'"
          If rs.NoMatch Then
             rs.AddNew
             rs![Formulaire] = oAccObj.Name
          Else
             rs.Edit
          End If
          rs![Table] = strTblName
          rs![Champ] = strField
          rs.Update
       End If
    End If
Next
 
' Etats E_AutoXXXXX
Set rs = db.OpenRecordset("tbl_TempLstE", dbOpenDynaset)
 
For Each oAccObj In CurrentProject.AllReports
    If oAccObj.Name Like "E_Auto*" Then
       strTblName = Mid(oAccObj.Name, 7, Len(oAccObj.Name) - 6)
       Set tdef = Nothing
       Set tdef = db.TableDefs(strTblName)
       If Not tdef Is Nothing Then
          rs.FindFirst "[Etat]='" & oAccObj.Name & "'"
          If rs.NoMatch Then
             rs.AddNew
             rs![Etat] = oAccObj.Name
          Else
             rs.Edit
          End If
          rs![Table] = strTblName
          rs.Update
       End If
    End If
Next
 
ENDPROC:
db.Close
Exit Sub
 
ERRH:
If Err.Number = 3265 Then
   Resume Next
Else
    If MsgBox(CStr(Err.Number) & vbCrLf & vbCrLf & Err.Description, _
                  vbYesNo, "Debug ?") = vbYes Then
       Stop       ' Faire deux fois F8 pour voie la ligne fautive
       Resume
    Else
       Resume ENDPROC
    End If
End If
 
End Sub

Peux tu m’aider ? SVP Merci
Raphael

**LedZeppII** · 31/08/2006, 08h58

Bonjour,

essaie en mettant Public devant Function EnumAutoFrmsRpts()

A+

**Raphael39** · 31/08/2006, 13h51

Bonjour,

Merci pour l'aide mais cela "bug" toujours de la meme facon. Veux-tu que je t'envoie le "Bebe" en "Light et Zipé"

Raphaël

**LedZeppII** · 31/08/2006, 19h35

Salut Raphaël,

Je crois que je sais pourquoi.
Dans la macro, ajoute des parenthèses au nom de la fonction :
   Action : ExécuterCode
   Nom de fonction : EnumAutoFrmsRpts()

Si le problème persiste, ok tu m'envoie la base.

A+

**Raphael39** · 01/09/2006, 10h28

Bonjour,

Merci pour cette correction cela marche sauf que pour la table tbl_TempLstE cela cree bien l'enregistrement mais il manque dans celui-ci le la valeur du champ "Champ". As tu, encore, une de tes brillantes idées a me proposer ?

Je viens de t'envoyer la base a l'adresse email de notre dernier echange.

SVP Merci

Raphaël

Double clic et recherche multicriteres

VBA Access

Discussions similaires

Partager

Partager