visual basic appliqué à access

Version imprimable

Voir 40 message(s) de cette discussion en une page

Re re Bonjour,

Je m'excuse de passer du coq à l'âne, mais mon problème actuel est le suivant :
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 'AJOUTER (pas remplacer) la somme calculée au prix contenu dans la table PRIX Private Sub Ajout_Prix() Dim oDb As DAO.Database Dim oRs As Recordset Dim sSql As String sSql = "SELECT * FROM PRIX WHERE Reference_Article =""" & GlobREF & """" Set oDb = CurrentDb Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset) If oRs.RecordCount <> 0 Then MsgBox ("Enregistrement : " & oRs.Fields("Reference_Article") & " ;" & _ " Prix : " & oRs.Fields("Prix_U")) oRs.Edit oRs.Fields("Prix_U") = oRs.Fields("Prix_U") + PRIX_TOTAL oRs.Update MsgBox ("Enregistrement : " & oRs.Fields("Reference_Article") & " ; " & _ "Somme à ajouter : " & PRIX_TOTAL & " ; Prix après ajout : " & oRs.Fields("Prix_U")) End If oRs.Close Set oRs = Nothing Set oDb = Nothing End Sub
Ce code est censé ajouter la somme contenu dans la variable PRIX_TOTAL à la valeur contenu dans le champ "Prix_U" de la table PRIX pour lequel GlobREF = Reference_Article (Reference_Article étant un champ de la table PRIX).

Les MsgBox me permette de vérifier au fur et à mesure de l'exécution du code l'évolution des différentes variables, avant et après ajout de PRIX_TOTAL. Mais PRIX_TOTAL a beau être > à 0, la valeur contenu dans oRs.Fields("Prix_U") n'évolue pas entre avant et après l'ajout de PRIX_TOTAL.

Je continue d'investiguer tout en étant preneur de vos suggestions !

Modif
Je précise au passage, que PRIX_TOTAL est déclaré en "Double" et le contenu de oRs.Fields("Prix_U") est de type "Numerique"...

Aïe aïe aïe !
J'ai toujours des difficultés avec la syntaxe :
Code:

1 2 3 4 5 6 7 ... strCodeSql = "SELECT SUM([NOM_EL_PRIX]![Prix_T]) FROM [NOM_EL_PRIX] "WHERE" & _ Nomenclature ='" & sREF & "'" Set oRs = oDb.OpenRecordset(strCodeSql, dbOpenDynaset) ...
Ceci me renvoi à la ligne Set oRs...... en m'indiquant "Trop peu de paramètres".

06/06/2006, 17h31
micniv
Bonjour

ta requete devrait plutot etre comme ceci :
Code:

1 2 3 4 strCodeSql = "SELECT SUM([NOM_EL_PRIX]![Prix_T]) _ FROM [NOM_EL_PRIX] WHERE Nomenclature ='" & sREF & "'"
Essaie de tester tes requetes dans le QBE (l'interface des requetes)

Bon courage
06/06/2006, 17h47
microman
Citation:
Envoyé par micniv

Bonjour

ta requete devrait plutot etre comme ceci :

Code:

1 2 3 4 5 ... strCodeSql = "SELECT SUM([NOM_EL_PRIX]![Prix_T]) FROM [NOM_EL_PRIX]" & _ " WHERE Nomenclature ='" & sREF & "'" ...

Essaie de tester tes requetes dans le QBE (l'interface des requetes)

Bon courage
Juste une citation pour plus de lisibilité du code.

En effet il y avait erreur, mais dans mon code c'était bien écrit... Faute de frappe pendant le post de mon message sans doute.

J'ai donc toujours le joli même message d'erreur !
06/06/2006, 19h29
microman

re
rPour rechercher un enregistrement dans une table, j'utilise un requête Sql puis un objet recordset comme l'illustre le code qui suit :
Code:

1 2 3 sSql = "SELECT * FROM PRIX WHERE Reference_Article =""" & GlobREF & """" Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset)
Cette écriture impose à VBA de parcourir la totalité des enregistrement de la table PRIX pour y récupérer les enregistrements correspondant à GlobREF. Or je sais qu'il y a un seul enregistrement à trouver quelque soit GlobREF.
Dans un soucis de temps d'exécution (réel soucis dans mon cas : la table PRIX contient 75 000 enregistrements), je souhaiterai donc que la recherche s'arrête dès que l'enregistrement est trouvé.

Mais je ne sais pas comment écrire ça :
-Dois je toujours utiliser une requête Sql ?
-J'ai entendu parler de ".seek", ".NoMatch" mais n'y connait rien pour l'instant...

Donc si vous avez une solution à me proposer j'en suis très friand !

Et voilà ma procédure qui fonctionne avec .Seek !
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 Private Sub Ajout_Prix() Dim MaBd As Database Dim MaTable As Recordset Dim Critere As String Set MaBd = CurrentDb Critere = GlobREF Set MaTable = MaBd.OpenRecordset("PRIX") MaTable.Index = "Reference" MaTable.Seek "=", Critere If MaTable.NoMatch Then MaTable.Close MsgBox ("Référence < " & GlobREF & " > non trouvée dans la table PRIX.") Else MaTable.Edit MaTable("Prix_U") = PRIX_TOTAL MaTable.Update MaTable.Close End If Set MaTable = Nothing Set MaBd = Nothing End Sub
Celà dit elle ne me sert à rien de plus que la version avec requête Sql ! Ce n'est pas plus rapide du tout!

J'ai par contre identifié précisément d'où vient mon problème de lenteur d'exécution ! (D'une autre procédure)
Code:

1 2 3 4 5 6 Psearch = "SELECT SUM([Req_TabArbo2]![Prix_T_Sous_REF]) " & _ "FROM [Req_TabArbo2] WHERE REF ='" & REF & "'" MsgBox "debut recordset" Set oRs2 = oDb.OpenRecordset(Psearch) MsgBox "fin recordset"
Entre mes 2 MsgBox j'ai une à 2 secondes ! Hors dans mon code ces lignes sont parcourues une vingtaine de fois, j'arrive donc vite à un temps d'exécution d'une 20taine de secondes ! Mais que faire ??

07/06/2006, 10h33
loufab
As-tu essayé avec un Dsum() au lieu de la requête ?
Code:

1 2 masomme=DSUM("[Prix_T]","[NOM_EL_PRIX]","[Nomenclature]='" & sREF & "'")
Ce n'est pas sur que tu y gagnes en temps d'execution... à voir

Cordialement,

Je ne sais pas si c'est parce que j'utilise Access 97 mais DSUM n'a pas l'air accepté...à voir... je veux pas trop m'avancer.

Celà dit c'est bon j'ai réussi !!
L'exécution du code suivant est quasi instantannée par rapport à 20 à 30 secondes avant !
Code:

1 2 3 4 5 6 7 8 9 10 Do Until oRs.EOF = True If oRs.Fields("REF") = REF Then PRIX_TOTAL = PRIX_TOTAL + IIf(IsNull(oRs.Fields("Prix_T_Sous_REF")) , 0, oRs.Fields("Prix_T_Sous_REF")) oRs.MoveNext Else Call Ajout_Prix GoTo fin End If
J'ai pas copié tout le code mais l'idée est que je fais la somme manuellement (PRIX_TOTAL = PRIX_TOTAL + .....)
et il faut croire que dans mon cas c'est beaucoup plus rapide que d'utiliser "SUM" !

07/06/2006, 20h34
philben
Bonjour Julien,

Il existe une écriture équivalente à cette ligne, peut-être plus rapide :
Code:

1 2 3 4 PRIX_TOTAL = PRIX_TOTAL + IIf(IsNull(oRs.Fields("Prix_T_Sous_REF")) , 0, oRs.Fields("Prix_T_Sous_REF"))
qui est :
Code:

1 2 3 PRIX_TOTAL = PRIX_TOTAL + nz(oRs.Fields("Prix_T_Sous_REF"),0)
La fonction nz permet de tester le contenu de ta variable.
Si elle est n'est pas NULL, la valeur de la variable est renvoyée.
Si elle est NULL, elle retourne la valeur spécifiée dans le 2ème paramètre (ici 0), ce deuxième paramètre est facultatif.

Je ne sais pas si ton <goto fin> permet seulement de sortir de la boucle Do, mais les puristes préfèrent éviter au maximum les <GoTo> (nuisent à la lisibilité du code) surtout si une fonction spécifique existe. Ici, un <Exit Do> pourrait faire l'affaire (qui est elle même à éviter car créée un deuxième chemin de sortie de ta boucle et réduit ainsi la lisibilité du code).

Il s'agit d'un avis personnel mais je pense qu'il est généralement partagé (J'espère que Papy Turbo ne va pas m'incendier ! ;) )

Si on commence à chipoter avec les détails, c'est bon signe pour toi !!!

amicalement,

Philippe
07/06/2006, 21h42
microman

re

Merci beaucoup ! Cette écriture simplifiée par la fonction "nz" va éclaircir le code !

Concernant le Goto il permet en effet de sortir de la boucle "Do", et j'ai bien essayé de l'éviter mais pour l'instant je ne vois pas comment faire. J'ai déjà amélioré son utilisation car avant il faisait appel à une étiquette placée en amont du code. Là, l'étiquette se situe en aval. Celà dit il est assez rarement utilisé lors de l'exécution du code. Enfin tout est une question de proportion (!)... à voir. Merci pour le conseil !
----------------------------------------------------------------
Maintenant que mon formulaire est opérationnel, je souhaiterai l'exécuter à partir d'un autre formulaire (lorsque je clique sur un bouton).

Sachant que pour s'exécuter mon sous formulaire utilise la reference contenue dans une zone de liste.

La procédure mère du sous formulaire est en l'occurence :

Code:

Private Sub Liste0_Click()

et la valeur (ou référence) indispensable à son exécution est :

Code:

Me.Liste0.Value

Idée : Je suppose qu'il faut insérer du code dans la procédure du bouton du formulaire parent, mais quel code...(?)
Quelque chose comme ça ?...

Code:

Call Private Sub Liste0_Click

avec ça ?...

Code:

Me.Liste.Value = "001-234-645"

(la référence chiffrée n'est qu'un exemple)

c bon

C'est bon, j'ai fais ceci :
Lors du click sur un bouton dans le formulaire appellant le code suivant est exécuté :

Code:

1
2
3
4
5
6
7
8
 
Private Sub MAJ_Click()
If Not IsNull(Me.ref_nom.Value) Then
DoCmd.OpenForm "FormRechSousNom" 'ouverture du formulaire FormRechSousNom
Else
MsgBox "Saisir une nomenclature dans la zone de texte."
End If
End Sub

dans le Form_load du formulaire appellé :

Code:

1
2
3
4
5
6
7
8
 
Sub Form_load()
On Error GoTo err 'permet d'ouvrir le formulaire FormRechSousNom qd 
                        'le formulaire Nomenclature est fermé
Me.Liste0.Value = Forms![Nomenclature]![ref_nom]
Call Liste0_Click 'appel de la procédure utilisant Me.Liste0.Value
err:
End Sub

Alright !

Enfin mon formulaire est fini !!
Merci 1000 fois à tous ceux qui m'ont aidé en complément de la FAQ Access, avec une mention spéciale pour Philippe !

Si ça peut faire passer le temps à quelques acharnés de VB, voilà le code...
Si vous y voyez des maladresses dans la syntaxe faites m'en part !

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
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
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
 
 
Option Compare Database
Option Explicit
'variables globales
Dim PRIX_TOTAL As Double 'évite de spécifier d'argument pour les procédures l'utilisant
Dim Prem_Ouv As String 'variable pour test de première ouverture de la table Prix_Nul
Dim GlobRef As String 'évite de spécifier d'argument pour l'appel de Ajout_Prix par MAJ_Prix
Dim GlobSauvTab1 As String 'contient chacune des références trouvées à enregistrer
Dim Globiniveau As String 'contient le niveau à enregistrer de chaque référence trouvées
 
Sub Form_load()
Forms!FormRechSousNom.SetFocus 'activation du formulaire (mise au 1er plan)
 
'initialisation des variables
    Me.Liste2.RowSource = vbNullString 'initialisation des variables à 0 et non à "".
    Me.prof = 0
    Me.nb = 0
    Me.Balayage.Caption = 0
    prix_total_nom.Caption = 0
    prix_total_nom_A.Caption = 0
    prix_total_nom_F.Caption = 0
    stat_A.Caption = 0
    Stat_F.Caption = 0
    Prem_Ouv = 0
Me.Repaint
 
On Error GoTo err 'permet d'ouvrir le form FormRechSousNom quand le form Nomenclature est fermé
Me.Liste0.Value = Forms![Nomenclature]![ref_nom]
Call Liste0_Click
err:
End Sub
 
Private Sub Liste0_Click() 'Procédure se déclenchant à la sélection d'une référence dans la liste déroulante
'test de contenu non nul de la zone de texte de saisie
If IsNull(Me.Liste0.Value) Then
Exit Sub
End If
 
On Error GoTo err
 
'déclarations de variables
    Dim oDb As DAO.Database
    Dim strReqSQL As String
    Set oDb = CurrentDb()
    Dim Prix_A As Double
    Dim Prix_F As Double
    Dim Verif_Prix_T As Double
 
'initialisation de variables
 
    DoCmd.Close acQuery, "Req_TabPrixNul" 'Fermeture de la requête si ouverte
    DoCmd.Close acTable, "TabArbo" 'Fermeture de la table si ouverte
 
    Me.Liste2.RowSource = vbNullString 'initialisation des variables à 0 et non à "".
    Me.prof = 0 'variable contenant la profondeur maximal d'une arborescence
    Me.nb = 0 'variable contenant le nombre de sous nomenclatures trouvées
    Me.Balayage.Caption = 0
        prix_total_nom_A.Caption = 0
        prix_total_nom_F.Caption = 0
        prix_total_nom.Caption = 0
    stat_A.Caption = 0
    Stat_F.Caption = 0
    Prem_Ouv = 0
        check_rech_sous_nom.Caption = ""
        check_MAJ_Prix.Caption = ""
        check_MAJ_Prix_A.Caption = ""
        check_MAJ_Prix_F.Caption = ""
    Me.Repaint
    DoCmd.Hourglass True 'affichage du sablier d'attente
 
'appel de sous procédures
    Call SupprTabArbo 'suppression de la table de visualisation de l'arborescence
    Call SupprTabArbo2 'suppression de la table qui indique le niveau de chaque nomenclature
    Call SupprTabPrixNul 'suppression de la table de sauvegarde des réf à prix nul
    Globiniveau = 0 'mise à 0 de la variable de niveau des réf trouvées pour initialiser le 1er chp de TabArbo
    Call CreerTabArbo 'appel la procédure de création de la table de stockage structuré des données
    Call CreerTabArbo2 'appel la procédure de création de la table de stockage NON structuré des données
    Call CreerTabPrixNul 'appel la procédure de création de la table de stockage des pièces non chiffrées
 
AutoCall oDb, Me.Liste0.Value, 0 'appel Autocall avec args : oDb = Base de donnée, sREF = ref saisie, 0 = iniveau
check_rech_sous_nom.Caption = "Effectué"
Me.Repaint
 
Me.nb = Me.Liste2.ListCount 'stockage dans nb du nbre de ref trouvées
Me.Repaint
Set oDb = Nothing 'libération de la base
 
'appel des procédures de mise à jour des tables PRIX, PRIX_A et PRIX_F
    Call MAJ_Prix
        check_MAJ_Prix.Caption = "Effectué"
        Me.Repaint
    Call MAJ_Prix_A
        check_MAJ_Prix_A.Caption = "Effectué"
        Me.Repaint
    Call MAJ_Prix_F
        check_MAJ_Prix_F.Caption = "Effectué"
        Me.Repaint
 
'affichage des résultats
    Call Calc_Prix_TOTAL(Me.Liste0.Value)
    Call Calc_Prix_TOTAL_A(Me.Liste0.Value)
    Call Calc_Prix_TOTAL_F(Me.Liste0.Value)
 
'test de vérification des prix
    Prix_A = prix_total_nom_A.Caption
    Prix_F = prix_total_nom_F.Caption
    Verif_Prix_T = (Prix_A + Prix_F)
        If Verif_Prix_T <> prix_total_nom.Caption Then
        MsgBox "Partie Achat + Partie Fab non égale au prix total."
        End If
'affichage des pourcentages du prix total des pièces achetées et des pièces fabriquées
    If (prix_total_nom.Caption <> 0) Then
    stat_A.Caption = Int((prix_total_nom_A.Caption / prix_total_nom.Caption) * 100)
    Stat_F.Caption = Int((prix_total_nom_F.Caption / prix_total_nom.Caption) * 100)
    End If
 
Balayage.Caption = 0
DoCmd.Hourglass False 'désactivation du sablier d'attente
Me.Repaint 'actualisation de l'affichage du formulaire
 
'msgbox "Fin du Code."
Exit Sub
err:
'En cas d’erreur, affichage du message d’erreur avec le numéro d’erreur
Call MsgBox(err.Number & " " & err.Description, vbCritical)
End Sub
 
Private Sub SupprTabArbo() 'suppression de la table TabArbo
    On Error GoTo err
    Dim oDb As DAO.Database
    Dim NomTable As String
    NomTable = "TabArbo"
    DoCmd.DeleteObject acTable, NomTable
    Set oDb = Nothing
err:
End Sub
 
Private Sub SupprTabArbo2() 'suppression de la table TabArbo2
    On Error GoTo err
    Dim oDb As DAO.Database
    Dim NomTable As String
    NomTable = "TabArbo2"
    DoCmd.DeleteObject acTable, NomTable
    Set oDb = Nothing
err:
End Sub
 
Private Sub SupprTabPrixNul() 'suppression de la table TabPrixNul
    On Error GoTo err
    Dim oDb As DAO.Database
    Dim NomTable As String
    NomTable = "TabPrixNul"
    DoCmd.DeleteObject acTable, NomTable
    Set oDb = Nothing
err:
End Sub
 
Private Sub CreerTabArbo() 'création de TabArbo
On Error GoTo err
Dim oDb As DAO.Database
Dim oNouvelleTable As DAO.TableDef
 
    Set oDb = CurrentDb 'Instancie la base de données
    Set oNouvelleTable = oDb.CreateTableDef("TabArbo") 'Crée la nouvelle table
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Niveau " & Globiniveau, dbText, 100)
    'Crée le champ dont le nom est contenu dans GlobNumChp et l'ajoute
    oDb.TableDefs.Append oNouvelleTable 'Ajoute la table à la base de données
 
oDb.Close 'Libère les variables
Set oNouvelleTable = Nothing
Set oDb = Nothing
Exit Sub
err:
Call MsgBox(err.Number & " " & err.Description, vbCritical)
End Sub
 
Private Sub CreerTabArbo2() 'création de TabArbo2
On Error GoTo err
Dim oDb As DAO.Database
Dim oNouvelleTable As DAO.TableDef
 
    Set oDb = CurrentDb 'Instancie la base de données
    Set oNouvelleTable = oDb.CreateTableDef("TabArbo2") 'Crée la nouvelle table
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Référence", dbText, 100)
    'Crée le champ "Référence" et l'ajoute
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Niveau", dbLong, 100)
    'Crée le champ "Niveau" et l'ajoute
    oDb.TableDefs.Append oNouvelleTable 'Ajoute la table à la base de données
 
oDb.Close 'Libère les variables
Set oNouvelleTable = Nothing
Set oDb = Nothing
Exit Sub
err:
Call MsgBox(err.Number & " " & err.Description, vbCritical)
End Sub
 
Private Sub CreerTabPrixNul() 'création de TabPrixNul
On Error GoTo err
Dim oDb As DAO.Database
Dim oNouvelleTable As DAO.TableDef
Dim oIndex As DAO.Index
 
    Set oDb = CurrentDb 'Instancie la base de données
    Set oNouvelleTable = oDb.CreateTableDef("TabPrixNul") 'Crée la nouvelle table
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Référence pièce", dbText, 100)
    'Crée le champ "Référence" et l'ajoute
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Type pièce", dbText, 100)
    'Crée le champ "Niveau" et l'ajoute
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Qté dans sa Nomenclature", dbText, 100)
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Nomenclature", dbText, 100)
    oNouvelleTable.Fields.Append oNouvelleTable.CreateField("Designation pièce", dbText, 100)
    oDb.TableDefs.Append oNouvelleTable 'Ajoute la table à la base de données
 
'création d'un index sur le champ Type pièce (rapidité)
    Set oIndex = oNouvelleTable.CreateIndex("Index_Type")
    oIndex.Fields.Append oIndex.CreateField("Type pièce")
'Ajoute l'index à la table
    oNouvelleTable.Indexes.Append oIndex
 
oDb.Close 'Libère les variables
Set oNouvelleTable = Nothing
Set oDb = Nothing
Exit Sub
err:
Call MsgBox(err.Number & " " & err.Description, vbCritical)
End Sub
 
Private Sub AutoCall(oDb As DAO.Database, sREF As String, iniveau As String) 'recherche récursive de sous références
    Static siMaxNiveau As Integer
    Dim oRs As DAO.Recordset
    Dim sSql As String
    Globiniveau = iniveau
 
'test pour le calcul de la profondeur max de l'arborescence
    If iniveau = 0 Then
        siMaxNiveau = 0
    ElseIf iniveau > siMaxNiveau Then
        siMaxNiveau = iniveau
    End If
 
'requête SQL de sélection des sous références qui sont elles mêmes mères
    sSql = "SELECT REF_2 FROM TabChgtVar WHERE ((REF_1)=""" & sREF & """AND (TYPE_REF_2)=1)" ' AND ((REF_1)<>(REF_2)))"
 
'enregistrement des résultats de la requête SQL dans l'objet recordset oRs
    Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset)
 
'recherche récursive de références
    Do Until oRs.EOF = True
        GlobSauvTab1 = oRs.Fields(0) 'enregistrement du 1er chp du recordset ds la var globale GlobSauvTab1
        Call SauvTab 'appel la procédure d'enregistrement arboré des sous réf trouvées
        Call SauvTab2 'appel la procédure d'enregistrement avec niveau des sous réf trouvées
        Me.Liste2.RowSource = Me.Liste2.RowSource & oRs.Fields(0) & ";" 'ajout chaîne à listebox de résultats
 
    'appel récursif de Autocall pour recherche de sous références incrémentation de "1" du nombre de niveau
        AutoCall oDb, oRs.Fields(0), iniveau + 1
        Globiniveau = iniveau 'enregistrement du niveau courant dans la variable globale Globiniveau
        oRs.MoveNext 'déplacement à l'enregistrement suivant
    Loop
 
    If iniveau = 0 Then Me.prof = siMaxNiveau
    Set oRs = Nothing 'libération de la variable objet recordset
End Sub
 
Private Sub SauvTab() 'écriture dans TabArbo
Dim oDb As DAO.Database
Dim oRsTab As DAO.Recordset
 
Call AjtChpTabArbo 'appel de la procédure d'ajout automatique de champ
 
    Set oDb = CurrentDb
    Set oRsTab = oDb.OpenRecordset("TabArbo", dbOpenTable)
If (oRsTab.RecordCount <> 0) Then
    oRsTab.MoveLast
End If
    oRsTab.AddNew
    oRsTab.Fields("Niveau " & Globiniveau).Value = GlobSauvTab1
    oRsTab.Update
Balayage.Caption = GlobSauvTab1
Me.Repaint
Set oRsTab = Nothing
Set oDb = Nothing
End Sub
 
Private Sub AjtChpTabArbo() 'procédure d'ajout de chp dans la table TabArbo <> procédure SauvTab
On Error GoTo err
Dim oDb As DAO.Database
Dim oTbl As DAO.TableDef
Dim oFld As DAO.Field
 
    Set oDb = CurrentDb
    Set oTbl = oDb.TableDefs("TabArbo")
'Etape 1 : Créer le champ
    Set oFld = oTbl.CreateField("Niveau " & Globiniveau, dbText, 100)
'Etape 2 : Définir les propriétés
    oFld.AllowZeroLength = False 'Chaine vide autorisée : Non
    oFld.Required = False         'Null interdit : Oui
'Etape 3 : Ajouter le champ à la table
    oTbl.Fields.Append oFld
    oTbl.Fields.Refresh 'Rafraichir la collection
 
Exit Sub
err:
'si champ existe déjà Alors erreur = sortie procédure
End Sub
 
Private Sub SauvTab2() 'écriture dans TabArbo2
Dim oDb As DAO.Database
Dim oRsTab As DAO.Recordset
 
    Set oDb = CurrentDb
    Set oRsTab = oDb.OpenRecordset("TabArbo2", dbOpenTable)
If (oRsTab.RecordCount <> 0) Then
    oRsTab.MoveLast
End If
    oRsTab.AddNew
    oRsTab.Fields(0).Value = GlobSauvTab1
    oRsTab.Fields(1).Value = Globiniveau
    oRsTab.Update
Set oRsTab = Nothing
Set oDb = Nothing
End Sub
 
Private Sub MAJ_Prix()
Dim oDb As DAO.Database
Dim oRs As DAO.Recordset
Dim sSql As String
Dim REF As String
Set oDb = CurrentDb
 
sSql = "SELECT * FROM [Req_TabArbo2]"
Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset) 'mise en mémoire du contenu de la requête Req_TabArbo2
 
'Calcul des sommes des REF respectives
Do While oRs.EOF = False
    REF = oRs.Fields("REF")
    GlobRef = REF
        Do Until oRs.EOF = True
            If oRs.Fields("REF") = REF Then
                PRIX_TOTAL = PRIX_TOTAL + Nz(oRs.Fields("Prix_T_Sous_REF"), 0)
                oRs.MoveNext
            Else
            Call Ajout_Prix
            GoTo fin
            End If
        Loop
    Call Ajout_Prix 'Ajout du prix du dernier enregistrement de la requête Req_TabArbo2
fin:
    PRIX_TOTAL = 0
Loop
 
End Sub
 
Private Sub Ajout_Prix() 'ajout dans la table PRIX, du prix calculé dans MAJ_Prix de la référence en cours
Dim MaBd As Database
Dim MaTable As Recordset
Dim Critere As String
 
Set MaBd = CurrentDb
Critere = GlobRef
Set MaTable = MaBd.OpenRecordset("PRIX")
MaTable.Index = "Reference"
MaTable.Seek "=", Critere
 
If MaTable.NoMatch Then
    MsgBox ("Référence < " & GlobRef & " > non trouvée dans la table PRIX.")
    MaTable.Close
Else
    MaTable.Edit
    MaTable("Prix_U") = PRIX_TOTAL
    MaTable.Update
    MaTable.Close
End If
 
Set MaTable = Nothing
Set MaBd = Nothing
End Sub
 
Private Sub MAJ_Prix_A()
Dim oDb As DAO.Database
Dim oRs As DAO.Recordset
Dim sSql As String
Dim REF As String
 
Set oDb = CurrentDb
sSql = "SELECT * FROM [Req_TabArbo2_A]"
'enregistrement du contenu de la requête Req_TabArbo2
Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset)
 
'Calcul des sommes des REF respectives
Do While oRs.EOF = False
    REF = oRs.Fields("REF")
    GlobRef = REF
        Do Until oRs.EOF = True
            If oRs.Fields("REF") = REF Then
                PRIX_TOTAL = PRIX_TOTAL + Nz(oRs.Fields("Prix_T_Sous_REF"), 0)
                oRs.MoveNext
            Else
            Call Ajout_Prix_A
            GoTo fin
            End If
        Loop
    Call Ajout_Prix_A 'Ajout du prix du dernier enregistrement de la requête Req_TabArbo2
fin:
    PRIX_TOTAL = 0
Loop
 
End Sub
 
Private Sub Ajout_Prix_A()
Dim MaBd As Database
Dim MaTable As Recordset
Dim Critere As String
 
Set MaBd = CurrentDb
Critere = GlobRef
Set MaTable = MaBd.OpenRecordset("PRIX_A_ET_NOM")
MaTable.Index = "Reference"
MaTable.Seek "=", Critere
 
If MaTable.NoMatch Then
    MsgBox ("Référence < " & GlobRef & " > non trouvée dans la table PRIX_A_ET_NOM.")
    MaTable.Close
Else
    MaTable.Edit
    MaTable("PremierDePrix_Unitaire") = PRIX_TOTAL
    MaTable.Update
    MaTable.Close
End If
 
Set MaTable = Nothing
Set MaBd = Nothing
End Sub
 
Private Sub MAJ_Prix_F()
Dim oDb As DAO.Database
Dim oRs As DAO.Recordset
Dim sSql As String
Dim REF As String
 
Set oDb = CurrentDb
sSql = "SELECT * FROM [Req_TabArbo2_F]"
Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset) 'mise en mémoire du contenu de la requête Req_TabArbo2
 
'Calcul des sommes des REF respectives
Do While oRs.EOF = False
    REF = oRs.Fields("REF")
    GlobRef = REF
        Do Until oRs.EOF = True
            If oRs.Fields("REF") = REF Then
                PRIX_TOTAL = PRIX_TOTAL + Nz(oRs.Fields("Prix_T_Sous_REF"), 0)
                oRs.MoveNext
            Else
            Call Ajout_Prix_F
            GoTo fin
            End If
        Loop
    Call Ajout_Prix_F 'Ajout du prix du dernier enregistrement de la requête Req_TabArbo2
fin:
    PRIX_TOTAL = 0
Loop
 
End Sub
 
Private Sub Ajout_Prix_F()
Dim MaBd As Database
Dim MaTable As Recordset
Dim Critere As String
 
Set MaBd = CurrentDb
Critere = GlobRef
Set MaTable = MaBd.OpenRecordset("PRIX_F_ET_NOM")
MaTable.Index = "Reference"
MaTable.Seek "=", Critere
 
If MaTable.NoMatch Then
    MsgBox ("Référence < " & GlobRef & " > non trouvée dans la table PRIX_F_ET_NOM.")
    MaTable.Close
Else
    MaTable.Edit
    MaTable("PRIX_MINI_VENTE") = PRIX_TOTAL
    MaTable.Update
    MaTable.Close
End If
 
Set MaTable = Nothing
Set MaBd = Nothing
End Sub
 
Private Sub Calc_Prix_TOTAL(sREF As String) 'Calcul du prix total
Dim oDb As DAO.Database
Dim sSql As String
Dim oRs As DAO.Recordset
    Set oDb = CurrentDb
    sSql = "SELECT SUM([NOM_EL_PRIX_2]![Prix_T]) FROM [NOM_EL_PRIX_2] WHERE Nomenclature ='" & sREF & "'"
    Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset)
    prix_total_nom.Caption = Nz(oRs(0), 0)
End Sub
 
Private Sub Calc_Prix_TOTAL_A(sREF As String) 'Calcul du prix total des pièces achetées
Dim oDb As DAO.Database
Dim sSql As String
Dim oRs As DAO.Recordset
    Set oDb = CurrentDb
    sSql = "SELECT SUM([NOM_EL_PRIX_A]![Prix_T]) FROM [NOM_EL_PRIX_A] WHERE Nomenclature ='" & sREF & "'"
    Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset)
    prix_total_nom_A.Caption = Nz(oRs(0), 0)
End Sub
 
Private Sub Calc_Prix_TOTAL_F(sREF As String) 'Calcul du prix total des pièces fabriquées
Dim oDb As DAO.Database
Dim sSql As String
Dim oRs As DAO.Recordset
    Set oDb = CurrentDb
    sSql = "SELECT SUM([NOM_EL_PRIX_F]![Prix_T]) FROM [NOM_EL_PRIX_F] WHERE Nomenclature ='" & sREF & "'"
    Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset)
    prix_total_nom_F.Caption = Nz(oRs(0), 0)
End Sub
 
Private Sub bt_Prix_nul_Click()
'test de première ouverture de la table TabPrixNul :
'si déjà ouvert alors pas de re-calcul = gain de temps
If Prem_Ouv = 1 Then
DoCmd.OpenQuery "Req_TabPrixNul"
Exit Sub
End If
 
Dim oDb As DAO.Database
Dim oRs As DAO.Recordset
Dim sSql As String
Set oDb = CurrentDb
 
Dim Prix As String
Dim Type_REF As String
Dim SOUS_REF As String
Dim REF As String
Dim QTE_PIECE As String
Dim DESIGN As String
 
DoCmd.Hourglass True
sSql = "SELECT * FROM [Req_TabArbo2]"
Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset) 'mise en mémoire du contenu de la requête Req_TabArbo2
 
Do While oRs.EOF = False
    Prix = Nz(oRs.Fields("Prix_T_Sous_REF"), 0)
    Type_REF = Nz(oRs.Fields("Type_REF"), 0)
        If ((IsNull(Prix) Or Prix = 0) And (Type_REF <> 1)) Then
            SOUS_REF = Nz(oRs.Fields("SOUS REF"), 0)
            REF = Nz(oRs.Fields("REF"), 0)
            QTE_PIECE = Nz(oRs.Fields("Qte_Sous_REF"), 0)
            DESIGN = Nz(oRs.Fields("designation"), 0)
            Call Prix_nul(Prix, SOUS_REF, Type_REF, REF, QTE_PIECE, DESIGN)
        End If
    oRs.MoveNext
Loop
 
DoCmd.Hourglass False
DoCmd.OpenQuery "Req_TabPrixNul" 'ouverture de TabPrixNul
Prem_Ouv = 1 'mise à 1 de Prem_Ouv pour test de 1ière ouverture
End Sub
 
Private Sub Prix_nul(Prix, SOUS_REF, Type_REF, REF, QTE_PIECE, DESIGN)
Dim oDb As DAO.Database
Dim oRsTab As DAO.Recordset
Set oDb = CurrentDb
Set oRsTab = oDb.OpenRecordset("TabPrixNul", dbOpenTable)
 
    If (oRsTab.RecordCount <> 0) Then
        oRsTab.MoveLast
    End If
 
oRsTab.AddNew
oRsTab.Fields(0).Value = SOUS_REF
 
    If Type_REF = 2 Then
        oRsTab.Fields(1).Value = "Fabriquée"
        ElseIf Type_REF = 3 Then
        oRsTab.Fields(1).Value = "Achetée"
        Else
        oRsTab.Fields(1).Value = "Non Renseigné"
    End If
 
oRsTab.Fields(2).Value = QTE_PIECE
oRsTab.Fields(3).Value = REF
 
    If DESIGN <> "" Then
        oRsTab.Fields(4).Value = DESIGN
        Else
        oRsTab.Fields(4).Value = "Non Renseigné"
    End If
 
oRsTab.Update
Set oRsTab = Nothing
Set oDb = Nothing
End Sub
 
'Copie de la référence cliquée, dans la listebox de recherche
Private Sub Liste2_dblClick(Cancel As Integer)
    Forms![FormRechSousNom].Form![Liste0] = Forms![FormRechSousNom]![Liste2]
    Call Liste0_Click
End Sub
 
Private Sub bt_arbo_Click()
'ouverture de la table TabArbo
    DoCmd.OpenTable "TabArbo"
End Sub
 
Private Sub quitter_Click()
'Fermeture du formulaire
    DoCmd.Close
End Sub

Et dire que je ne connaissait rien à VBA il y a 1 mois...
En espérant que mon travail puisse permettre à d'autres de s'initier à Visual Basic appliqué à Access.
Je mettrai le fichier .mdb en téléchargement seulement après avoir modifié les données confidentielles.

17/06/2006, 09h54
philben

Bonjour Julien,

Félicitations !!!

Citation:

Si vous y voyez des maladresses dans la syntaxe faites m'en part !

des "maladresses" y'en a quelques unes, tes utilisateurs vont pas manquer de te le dire...

...Mais les fondements d'un bon code sont là (documentation, indentation, variables à peu près explicite,...)

Avec l'expérience, tu vas créer plus de fonctions génériques, moins typées ce qui te permettra de te faire un pool de fonctions sur lesquelles tu baseras les spécificités de chacune de tes applications. Tu gagneras alors en temps de développement et tu auras moins de bugs à corriger à chaque fois.

Pour une fois que la fainéantise rejoint la qualité, ne pas s'en priver !!!

En particuliers, tu devrais te créer un gestionnaire d'erreurs avec traçage dans une table, et selon la gravité, possibilité de t'envoyer par Mail le message d'erreur de l'utilisateur, etc...
Il faut un code robuste sur les erreurs prévisibles et passer par un gestionnaire d'erreur pour les erreurs "a l'insu de mon plein grès !"

Citation:

Enfin mon formulaire est fini !!

ta première version mise en production est finie, tu vas voir les mises à jour !

Pour exemple, j'ai mis en place une application sous Access pour optimiser des tournées (sélection automatique des clients autour d'une ville selon distance et quadrant, ou sur un trajet entre communes) avec interfaçage de MapPoint dans Access pour optimiser l'ordre des visites pour réduire le temps de conduite, etc...) + gestion du planning journalier + interfacage avec les GPS TomTom (création d'une base commune des adresses GPS des clients (POI) et gain de temps pour positionner les clients sur la carte MapPoint), édition feuilles de route avec horaires, fiche client, etc... (Appli de 8 Mo + tables sur serveur).

Bref, entre mes mises à jour et celles demandées par les utilisateurs (Ergonomie, adaptations, corrections,...) j'en suis à la version 1.21 au bout d'1 an, mais avec une décroissance rapide du nombre de mises à jour avec le temps ! (bon signe...)

Gain de productivité : 15/20 %, avec joie et bonne humeur !

Tout ça pour te dire bon courage, bravo pour ta progression très rapide, et merci pour ta discussion/Blog (!) très pédagogique.

Amicalement,

Philippe

Merci beaucoup !

Mais pour le coup je me sens un peu bête...

Dans la procédure suivante :

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
Private Sub AutoCall(oDb As DAO.Database, sREF As String, iniveau As String) 
'recherche récursive de sous références

    Static siMaxNiveau As Integer
    Dim oRs As DAO.Recordset
    Dim sSql As String
    Globiniveau = iniveau

'test pour le calcul de la profondeur max de l'arborescence
    If iniveau = 0 Then
        siMaxNiveau = 0
    ElseIf iniveau > siMaxNiveau Then
        siMaxNiveau = iniveau
    End If

'requête SQL de sélection des sous références qui sont elles mêmes mères
    sSql = "SELECT REF_2 FROM TabChgtVar WHERE ((REF_1)=""" & sREF & """AND (TYPE_REF_2)=1 _
 AND ((REF_1)<>(REF_2)))"
    
'enregistrement des résultats de la requête SQL dans l'objet recordset oRs
    Set oRs = oDb.OpenRecordset(sSql, dbOpenDynaset)

'recherche récursive de références
    Do Until oRs.EOF = True
        GlobSauvTab1 = oRs.Fields(0) 'enregistrement du 1er chp du recordset ds la var globale GlobSauvTab1
        Call SauvTab 'appel la procédure d'enregistrement arboré des sous réf trouvées
        Call SauvTab2 'appel la procédure d'enregistrement avec niveau des sous réf trouvées
        Me.Liste2.RowSource = Me.Liste2.RowSource & oRs.Fields(0) & ";" 'ajout chaîne à listebox de résultats
        
    'appel récursif de Autocall pour recherche de sous références incrémentation de "1" du nombre de niveau
        AutoCall oDb, oRs.Fields(0), iniveau + 1
        Globiniveau = iniveau 'enregistrement du niveau courant dans la variable globale Globiniveau
        oRs.MoveNext 'déplacement à l'enregistrement suivant
    Loop

    If iniveau = 0 Then Me.prof = siMaxNiveau
    Set oRs = Nothing 'libération de la variable objet recordset
End Sub

Pourquoi n'y a t-il pas de "Endif" après le "if" ? J'ai essayé (par curiosité) d'en ajouter un mais ça provoque un message d'erreur : "Endif sans if" 8O

Bonjour

Lorsque IF et THEN ne forment qu'une ligne, il ne faut pas ENDIF.
Tu te serviras de ENDIF lorsqu'il y a plusieurs instructions dans le bloc IF... END IF
Exemple
Code:

1 2 IF Temps = beau THEN JeVaisPromener
Tu peux aussi écrire
Code:

1 2 3 4 IF Temps = beau THEN JeVaisPromener END IF
Code:

1 2 3 4 5 6 7 IF Temps = beau THEN JeVaisPromener JeMangeUneGlace ELSE JeTravaille END IF
On pourrait aussi avoir
Code:

1 2 IF Temps = beau THEN JeVaisPromener ELSE JeTravaille
Ok?

20/06/2006, 15h11
microman

re

Merci pour cette réponse d'une pédagogie exemplaire, j'ai bien compris !
Bonne journée

Voir 40 message(s) de cette discussion en une page