BDs ACCESS, rédiger la requête de connexion, la requête d’ouverture de table, visualiser le résultat.

Présentation
Mon premier gros programme écrit en VBScript avec interface HTA, merci de votre indulgence.

Le but, plutôt que de lancer un gros projet, ce programme ne nécessitant aucune installation peut
s'avérer utile pour aider à la rédaction de requête SQL.

Programme utilisant ADO pour la partie dialogue avec la BDs (ACCESS exclusivement)
Nom du fichier à lancer, OutilBDsAccess.HTA
Sous fichiers, Fond.jpg, DBSHTA.ico, TBLHTA.ico, MultiTBLHTA.ico et StructGenTbl.hta.
Pour l'affichage les fichiers GenTblSpl.hta et GenTblMlt.HTA seront générés par le fichier
OutilBDsAccess.HTA, à l'endroit du dossier de celui ci.

Que permet ce programme
Ouverture BDs :
Choix DSN (noms de source utilisateur) et/ou par l’explorateur et/ou rédaction/modification
de connexion direct (écriture d’une ligne de connexion par défaut lors de ces choix).
Analyse du test, si réussi, affichage des noms de table et champs de la table.
Ouverture d’une table :
Choix dans la liste tables et/ou rédaction/modification dans la boite requête,
drag drop possible des noms de champs depuis la liste champs vers boite de rédaction de la requête.
Chaque test est géré si une erreur se produit, affichage n° et descriptif de la cause de l’erreur.

Visualisation.
Test connexion à la BDs
Bouton « Tester », message Ok ou descriptif de l’erreur

Test ouverture de table:
Bouton « Tester », renseignement sur le nombre d'enregistrements pouvant être retournée,
si l’utilisation de Sum, Count, Max, Min ou Avg présent dans la requête,
informations suivant l'une de ces conditions.

Bouton « Test+ », affichage du résultat sur 1 page.

Bouton « Test++ », affichage du résultat de la requête, par lot de XX enregistrements
(XX est à choisir dans la liste au dessous de ce bouton, de 25 à 100, par pas de 5)

Dans tout les cas, descriptif de l’erreur qui se serai produite.

A savoir, sur un HTA, un clique bouton droit de la souris permet une prévisualisation pour une sortie impression.

ZIP mise à jour le 26/09/2013, correction faite
Téléchargement
Compatibilité
Windows
0  0 
Téléchargé 143 fois Voir les 3 commentaires
Détails
Catégories : HTA VBS
Avatar de Francis MILLET
Rédacteur / Modérateur
Voir tous les téléchargements de l'auteur
Licence : Freeware
Date de mise en ligne : 3 juillet 2020




Avatar de ProgElecT ProgElecT - Rédacteur/Modérateur https://www.developpez.com
le 29/12/2011 à 17:43
Correction d'un bug
Dans la fonction VerifReqt(Req) remplacer le Case Else
Code : Sélectionner tout
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
'+++++++++++++++++++++++++++++++++++++++++++++++ Partie formatage de la rêquete +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function VerifReqt(Req)
'...............
                Case Else
                    If Pos > 1 then
						If Mid(Req, Pos - 1, 1) = " " Then 'Bon ************
							'le caractère spécial débute le mot mais pas la phrase
							Deb = Pos: MsgTemp = RecupMotDebute(Req, Deb, Len(Req))
							Pos = Fin
							Else
							If Pos = Len(Req) Then 'Bon **************
								'le caractère spécial finit le mot et la phrase
								Deb = 1: MsgTemp = RecupMotFinit(Req, Deb, Len(Req))
								Pos = Fin
								Else
								If Mid(Req, Pos + 1, 1) = " " Or Mid(Req, Pos + 1, 1) = "," Then 'Bon **************
									'le caractère spécial finit le mot mais pas la phrase
									Deb = 1: MsgTemp = RecupMotFinit(Req, Deb, Pos)
									Pos = Pos + 1
									Else
									'le caractère spécial est contenu dans le mot
									MsgTemp = RecupleMot(Req, Pos)
									If NotCara(Cpt) = "'" Then
										If left(MsgTemp,1) = "=" Or left(MsgTemp,1) = "<" Or left(MsgTemp,1) = ">" Then
											Else
											Req = Replace(Req, MsgTemp, Replace(MsgTemp, "'", "''"))
										End If
									End If
									Pos = Fin
								End If
							End If
						End If
					End IF
'...............
Avatar de ProgElecT ProgElecT - Rédacteur/Modérateur https://www.developpez.com
le 19/06/2013 à 17:57
Pour plus de facilité opérer dans cette ordre

1° ajout du title au checkbox chkTbl du cartouche requête table
remplacer la ligne 698 par:
Code : Sélectionner tout
	<INPUT Type="checkbox" name="chkTbl"  disabled="disabled" onClick="TestChekTbl" title="Si coché, vérification/modification de la rédaction de la requête"


2° ne pas ajouter des [......] sur les dates (sub VerifReqt).
remplacer les lignes 479, 480 et 481 par:
Code : Sélectionner tout
1
2
3
4
5
6
                If Left(MsgTemp, 1) = "#" Or Right(MsgTemp, 1) = "#" Then
                    'cas particulier des DATEs
                    Else
                    Req = Replace(Req, MsgTemp, "[" & MsgTemp & "]")
                    Req = Replace(Req, "[[", "[")
                    Req = Replace(Req, "]]", "]")
                End If


3° ne pas vérifier/modifier la rédaction de la requête si le checkbox chkTbl n'est pas coché (Sub OuvreTbl).
remplacer la ligne 362 par:
Code : Sélectionner tout
    If chkTbl.Checked Then SQL = VerifReqt(SQL)
Avatar de ProgElecT ProgElecT - Rédacteur/Modérateur https://www.developpez.com
le 03/07/2020 à 16:05
Salut

Après différents problèmes sous Windows 10, nouvelle mouture du programme principal OutilBDsAccess.HTA.
Code HTML : Sélectionner tout
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
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
<HEAD lang="fr"> 
<!-- <meta http-equiv="Content-Type" content="text/html;charset=iso-8859-15" /> --> 
<meta http-equiv="Content-Type" content="text/html;charset=iso-8859-15" /> 
  <title> Mes premiers pas pour un HTML Application </title> 
	<HTA:APPLICATION 
		id="OutilBDsAccess" 
		applicationname="OutilBDsAccess" 
		version="1" 
		ICON="DBSHTA.ico" 
 		MAXIMIZEBUTTON="no" 
		SCROLL="no" 
		BORDER = "thin"	> 
	> 
	<SCRIPT language="VBScript" type="text/vbscript">ResizeTo 815,580: MoveTo (Screen.Width-815)/2,(Screen.Height - 685) / 2</SCRIPT> 
</HEAD> 
  
<SCRIPT language="VBScript" type="text/vbscript"> 
        Option Explicit 
        Dim ChemSleep 'variable chemin du supstitut de la fonction WScript.sleep 
' Déclarations utilisables dans toute la partie VBScript  
    Const ForWriting = 2 
    Const AdBookmarkFirst = 1 
    Const adLockPessimistic = 2 
    Const adOpenStatic = 3 
    Const adUseClient = 3 
    Const adModeReadWrite = 3 
    Const adStateClosed = 0     'Indique que l'objet Recordset est fermé. 
    Const adStateOpen = 1       'Indique que l'objet est ouvert. 
    Const adStateConnecting = 2 'l'objet Recordset est en train de se connecter. 
    Const adStateExecuting = 4  'l'objet Recordset est en train d'exécuter une commande. 
    Const adStateFetching = 8   'les lignes de l'objet Recordset sont en cours d'extraction. 
  
    Dim Cnx, Rst 
    Dim NomDeLaBDs, NomDeLaTable 
    Dim TypeBD 
    Dim CheminNomDelabase 
    Dim ChemNomBDsDSN() 
    Dim DossierDuProg, ChemFichierModel 
    Dim SQL, SQLConnect, SQLTbl 
    Dim MsG, Memo 
    Dim T, U, V, NbrLgn, Deb, Fin 
    Dim oOption 
    Dim WshShell, Fso, F 
    Dim ContenuLgn, MsGPage 
'---------------------------------------------------------------------------------------------------------------------- 
Sub Window_Onload() 
        Dim ChemNomComplet 
        ChemNomComplet = OutilBDsAccess.CommandLine ' ChemNomComplet = Id du programme.CommandLine 
        DossierDuProg = Left(ChemNomComplet, (InStrRev(ChemNomComplet, "\", -1, vbTextCompare))) 
        DossierDuProg = Replace(DossierDuProg,Chr(34),"") 
    NbrTbl.Value = "0": NbrChamps.Value = "0" 
        'New du 02/07/2020 
                ' ************ procedure pour vérifier/créer un supstitut à la fonction Sleep, ****** 
                ' ************        car wscript.sleep ne marche pas dans un HTA              ****** 
                Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject") 
                Dim TempFolder : Set TempFolder = Fso.GetSpecialFolder(2) 
                Dim TempName : TempName = "Sleeper.vbs" 
                ChemSleep = TempFolder&"\"&TempName 
                Set TempFolder = NotHing 
                ' verifier que le systéme a ou n'a pas dèjà le supstitut à la fonction WScript.Sleep 
                If Not Fso.FileExists(ChemSleep) Then  
                        ' Création du fichier Sleeper.vbs, supstitut de la fonction WScript.Sleep 
                        Dim objOutputFile : Set objOutputFile = Fso.CreateTextFile(ChemSleep, True) 
                        objOutputFile.Write "wscript.sleep WScript.Arguments(0)" 
                        objOutputFile.Close 
                        Set objOutputFile = NotHing 
                End If 
                Set Fso = NotHing 
        ' ***********************************************************************************  
        'Fin New du 02/07/2020 
    RecupDSNs 
End Sub 
        ' ************************ utilisation du supstitut de WScript.Sleep ******************** 
        Sub Sleep(MSecs): CreateObject("WScript.Shell").Run ChemSleep &" "& MSecs,1,True: End Sub 
        ' *************************************************************************************** 
'----------------------------- Recuperation des noms de source utilisateur (DSN)--------------------------------------- 
Sub RecupDSNs() 
    Dim oReg, Rep 
    Dim ClefPrimaire, ClefSecondaire, ClefDSN 
    Dim TblClefDSN, DSN, StrDriver 
    Dim TblClefPro, Pro, StrChemNom 
    Const HKEY_CURRENT_USER = &H80000001 
    U = 0 
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") 
  
    ClefPrimaire = "Software\ODBC\ODBC.INI" 
    ClefSecondaire = ClefPrimaire & "\ODBC Data Sources" 
    oReg.EnumValues HKEY_CURRENT_USER, ClefSecondaire, TblClefDSN, Rep 
' ******* dans un premier temps, je me limite aux bases de données Access (mdb) (accdb)********** 
    For V = LBound(TblClefDSN) To UBound(TblClefDSN) 
        DSN = TblClefDSN(V) 
        'msgbox "DSN = " & DSN 'Noms des clefs DSN = nom de la source utilisateur 
        oReg.GetStringValue HKEY_CURRENT_USER, ClefSecondaire, DSN, StrDriver 
        'msgbox "DriverBd = " & StrDriver 'Nom du driver pour cette clef ex: Microsoft Access Driver (*.mdb) 
        'msgbox "StrDriver = " & StrDriver & vbnewline & "InStr = " & InStr(1, UCase(StrDriver), "*.accdb", vbTextCompare) & vbnewline & "V = " & V 
                If InStr(1, LCase(StrDriver), "*.mdb", vbTextCompare) <> 0 Or InStr(1, LCase(StrDriver), "*.accdb", vbTextCompare) <> 0 Then 
            'msgbox "StrDriver = " & StrDriver & vbNewLine & "V = " & V         ' Nom du driver pour cette clef ex: Microsoft Access Driver (*.mdb) 
            ClefDSN = ClefPrimaire & "\" & DSN 
            'msgbox "V = " & V & vbnewline & "StrDriver = " & StrDriver & vbnewline & "ClefDSN = " & ClefDSN                    'Software\ODBC\ODBC.INI\BDpourEssaisPerso 
            oReg.EnumValues HKEY_CURRENT_USER, ClefDSN, TblClefPro, Rep 
                        'msgbox "UBound(TblClefPro) ="  & vbnewline & UBound(TblClefPro) 'Software\ODBC\ODBC.INI\BDpourEssaisPerso 
            For T = LBound(TblClefPro) To UBound(TblClefPro) 
                Pro = TblClefPro(T) 'nom de la clef 
                oReg.GetStringValue HKEY_CURRENT_USER, ClefDSN, Pro, StrChemNom 
                            'msgbox "StrChemNom ="  & vbnewline & StrChemNom 
                'If InStr(1, UCase(StrChemNom), ".mdb", vbTextCompare) <> 0 Then 
                                If InStr(1, LCase(StrChemNom), ".mdb", vbTextCompare) <> 0 Or InStr(1, LCase(StrChemNom), ".accdb", vbTextCompare) <> 0 Then 
                    'msgbox StrChemNom 'chemin complet et nom de la BDs 
                    U = U + 1 
                    ReDim Preserve ChemNomBDsDSN(U) 
                    ChemNomBDsDSN(U - 1) = StrChemNom 
                    Set oOption = window.Document.createElement("OPTION") 
                    oOption.Text = DSN 
                    oOption.Value = "Option " & U - 1 
                    LstDsn.Add (oOption) 
                End If 
            Next 
        End If 
    Next 
 If U >= 1 Then chkBDsDSN.disabled = "" 
 End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub ChoixFichier() 
    If NameBDs.Value <> "" Then 
        CheminNomDelabase = NameBDs.Value 
        TypeBD = UCase(Right(CheminNomDelabase, InStr(1, StrReverse(CheminNomDelabase), ".", vbTextCompare) - 1)) 
                chkBDsFichier.disabled = "" 
        If chkBDsFichier.Checked Then 
                        txtRqtConnx.Value = DefiniProvider(TypeBD) & ";Data Source=" & NameBDs.Value & ";User Id=admin;Password=;" 
                        Else 
                        CheminNomDelabase = "" 
                End If 
        End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub tstBouton1() 
    If txtRqtConnx.Value = "" Then 
        If chkBDsFichier.Checked Then 
            If NameBDs.Value <> "" Then 
                                TypeBD = UCase(Right(NameBDs, InStr(1, StrReverse(NameBDs), ".", vbTextCompare) - 1)) 
                                txtRqtConnx.Value = DefiniProvider(TypeBD) & ";Data Source=" & NameBDs.Value & ";User Id=admin;Password=;" 
                        End If 
        End If 
    End If 
  
    If txtRqtConnx.Value = "" Then 
        MsgBox "Le test de connexion ne peut être fait." & vbCrLf & "la boite de requête BDs est vide", vbCritical, "Erreur" 
        Else 
        SQL = txtRqtConnx.Value 
        ConnBds 
        If Cnx.state = adStateOpen Then 
            AjoutLstTable 
            Cnx.Close: Set Cnx = Nothing 
            MsG = "Test Ok" 
            MsgBox MsG, vbInformation, "Connexion BDs" 
        End If 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Function DefiniProvider(BdType) 
        'msgbox "BdType = " & BdType 
        Select Case BdType 
                Case "MDB":DefiniProvider = "PROVIDER=Microsoft.Jet.OLEDB.4.0" 
                Case "ACCDB":DefiniProvider = "PROVIDER=Microsoft.ACE.OLEDB.12.0" 
                Case Else:DefiniProvider = "PROVIDER=Microsoft.Jet.OLEDB.4.0" 
        End Select 
End Function 
'---------------------------------------------------------------------------------------------------------------------- 
Sub VerifCnt() 
    Deb = InStr(1, txtRqtConnx.Value, "Data Source=", vbTextCompare) 
    If Deb <> 0 Then 
        Deb = Deb + Len("Data Source=") 
        Fin = InStr(Deb, txtRqtConnx.Value, ";", vbTextCompare) 
        If Fin <> 0 Then CheminNomDelabase = Mid(txtRqtConnx.Value, Deb, Fin - Deb) 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub ConnBds() 
    BtTester2.disabled = "disabled": BtTester3.disabled = "disabled": BtTester4.disabled = "disabled" 
    Set Cnx = Nothing 
    Set Cnx = CreateObject("ADODB.Connection") 
    Cnx.CursorLocation = adUseClient: Cnx.Mode = adModeReadWrite 
    On Error Resume Next 
    Cnx.Open SQL 
    If Err.Number <> 0 Then 
        MsG = "Erreur N°" & Err.Number & vbCrLf _ 
        & "Description:" & vbCrLf & Err.Description & vbCrLf _ 
        & "Impossible d'ouvrire la BDs " 
        MsgBox MsG, vbCritical, "Erreur connexion BDs" 
        Else 
        BtTester2.disabled = "": BtTester3.disabled = "": BtTester4.disabled = "" 
    End If 
    NomDeLaBDs = ExtratFichier(CheminNomDelabase) 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub AjoutLstTable() 
    Dim Schema, NomTable 
    Const adSchemaColumns = 4 
    'vide la liste tables 
    For V = LstTbl.length To 0 Step -1: LstTbl.Remove (V): Next 
    'connexion pour récupération des noms de tables 
    Set Schema = Cnx.OpenSchema(adSchemaColumns) 
    If Not Schema.EOF Then V = 1 Else V = 0 
    U = 0 
    While Not Schema.EOF 
        If Schema.Fields("Table_NAME") <> "" And NomTable <> Schema.Fields("Table_NAME") Then 
            NomTable = Schema.Fields("Table_NAME"): U = U + 1 
            'ajoute les noms de tables 
            Set oOption = window.Document.createElement("OPTION") 
            oOption.Text = NomTable 
            oOption.Value = NomTable 
            LstTbl.Add (oOption) 
        End If 
        Schema.MoveNext 
    Wend 
    Schema.Close 
    NbrTbl.Value = U 
    If V = 0 Then 
        NomDeLaTable = "Auncune table disponnible" 
        Set oOption = window.Document.createElement("OPTION") 
        oOption.Text = NomDeLaTable 
        oOption.Value = "Option " & V 
        LstTbl.Add (oOption) 
        chkTbl.Checked = "": chkTbl.disabled = "disabled": LstTbl.disabled = "disabled" 
        Else 
        chkTbl.disabled = "" 
        If chkTbl.Checked Then LstTbl.disabled = "" 
        NomDeLaTable = LstTbl.Value 
        RecupNomChamps 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub RecupNomChamps() 
    'vide le listage champs de la table 
    txtLstChamps.Value = "": Memo = "": SQL = txtRqtConnx.Value 
    ConnBds 
    SQL = "Select * From " & NomDeLaTable 
    OuvreTbl 
    U = 0 
    If Rst.state = adStateOpen Then 
        U = Rst.Fields.Count 
        For V = 1 To Rst.Fields.Count 
            If V > 1 Then Memo = Memo & vbCrLf 
            Memo = Memo & Rst.Fields(V - 1).Name 
        Next 
        Rst.Close: Set Rst = Nothing 
        txtLstChamps.Value = Memo 
    End If 
    NbrChamps.Value = U 
End Sub 
'------------------------------------------------ conserne txtLstChamps ---------------------------------------------------- 
Sub MouseEnter(Lobjet) 
    Memo = Lobjet.Value 
    Lobjet.Style.Height = 38 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub MouseExit(Lobjet) 
        Lobjet.Value = Memo 
  Lobjet.Style.Height = 22 
End Sub 
'--------------------------------------------Fin  conserne txtLstChamps ------------------------------------------------ 
Sub tstBouton2() 
    If txtRqtConnx.Value = "" Then 
        MsgBox "La connexion ne peut être fait." & vbCrLf & "la boite de requête BDs est vide", vbCritical, "Erreur" 
        Else 
        If txtOuvrTbl.Value = "" Then 
            MsgBox "Le test d'ouverture de table ne peut être fait." & vbCrLf & "la boite de requête TABLE est vide", vbCritical, "Erreur" 
            Else 
            SQL = txtRqtConnx.Value 
            ConnBds 
            If Cnx.state = adStateOpen Then 
                SQL = txtOuvrTbl.Value 
                OuvreTbl 
                If Rst.state = adStateOpen Then 
                    If SQL <> txtOuvrTbl.Value Then txtOuvrTbl.Title = "OldRequête:" & txtOuvrTbl.Value: txtOuvrTbl.Value = SQL Else txtOuvrTbl.Title = "" 
                    If Rst.EOF Then 
                        MsG = "Aucun enregistrement disponnible" & vbCrLf 
                        Else 
                        MsG = "Nbr. d'enregistrements: " & Rst.RecordCount & vbCrLf 
                        If InStr(1, UCase(SQL), "COUNT(") <> 0 Then MsG = "Count = " & Rst.Fields(0).Value & vbCrLf 
                        If InStr(1, UCase(SQL), "SUM(") <> 0 Then MsG = "Sum = " & Rst.Fields(0).Value & vbCrLf 
                        If InStr(1, UCase(SQL), "MAX(") <> 0 Then MsG = "Max = " & Rst.Fields(0).Value & vbCrLf 
                        If InStr(1, UCase(SQL), "MIN(") <> 0 Then MsG = "Min = " & Rst.Fields(0).Value & vbCrLf 
                        If InStr(1, UCase(SQL), "AVG(") <> 0 Then MsG = "Avg = " & Rst.Fields(0).Value & vbCrLf 
                    End If 
                    Rst.Close: Set Rst = Nothing 
                    Cnx.Close: Set Cnx = Nothing 
                    MsG = MsG & "Test Ok" 
                    MsgBox MsG, vbInformation, "Ouverture Table" 
                End If 
            End If 
        End If 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub tstBouton3() 
    If txtRqtConnx.Value = "" Then 
        MsgBox "La connexion ne peut être fait." & vbCrLf & "la boite de requête BDs est vide", vbCritical, "Erreur" 
        Else 
        If txtOuvrTbl.Value = "" Then 
            MsgBox "Le test d'ouverture de table ne peut être fait." & vbCrLf & "la boite de requête TABLE est vide", vbCritical, "Erreur" 
            Else 
            SQL = txtRqtConnx.Value 
            ConnBds 
            If Cnx.state = adStateOpen Then 
                SQL = txtOuvrTbl.Value 
                OuvreTbl 
                If Rst.state = adStateOpen Then 
                    If Rst.EOF Then 
                        MsG = "Test Ok, mais aucun enregistrement disponnible" & vbCrLf 
                        MsgBox MsG, vbInformation, "Ouverture Table" 
                        Exit Sub 
                    End If 
                                         
                                        'msgbox "1 je suis ICI juste avant CreatTbl" 
                                        CreatTbl 
                                        'msgbox "3 je suis ICI juste après CreatTbl" 
                                        Rst.Close: Set Rst = Nothing 
                    Cnx.Close: Set Cnx = Nothing 
                End If 
            End If 
        End If 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub CreatTbl() 
        MsGPage = "<HEAD lang=" & Chr(34) & "fr" & Chr(34) & "> " & vbCrLf _ 
        & "<title>Visu resultat de la requête</title>" & vbCrLf _ 
        & "  <HTA:APPLICATION" & vbCrLf _ 
        & "      id =" & Chr(34) & "GenTblSpl" & Chr(34) & vbCrLf _ 
        & "      applicationname =" & Chr(34) & "GenTblSpl" & Chr(34) & vbCrLf _ 
        & "      ICON=" & Chr(34) & "TBLHTA.ico" & Chr(34) & vbCrLf _ 
        & "      version =" & Chr(34) & "1" & Chr(34) & vbCrLf _ 
        & "  >" & vbCrLf _ 
        & "</HEAD>" & vbCrLf _ 
        & "<body>" & vbCrLf _ 
        & "<H5>Conserne la BDS: <em style=" & Chr(34) & "color: blue;" & Chr(34) & ">" & NomDeLaBDs & "</em>" & vbCrLf _ 
        & "Table: <em style=" & Chr(34) & "color: blue;" & Chr(34) & ">" & NomDeLaTable & "</em>" & vbCrLf _ 
        & "Requête: <em style=" & Chr(34) & "color: blue;" & Chr(34) & ">" & txtOuvrTbl.Value & "</em>" & vbCrLf _ 
        & "Nombre d'enregistrements: <em style=" & Chr(34) & "color: red;" & Chr(34) & ">" & Rst.RecordCount & "</em></H5>" & vbCrLf _ 
        & "<table cellspacing=" & Chr(34) & "0" & Chr(34) & " rules=" & Chr(34) & "all" & Chr(34) & " border=" & Chr(34) & "1" & Chr(34) & " style=" & Chr(34) & "border-collapse:collapse;" & Chr(34) & ">" & vbCrLf _ 
        & "    <tr style=" & Chr(34) & "background-color:#E0E0E0;" & Chr(34) & ">" & vbCrLf 
    'titrage colonnes avec les noms de champs 
    MsGPage = MsGPage & "        <td>&nbsp&nbsp</td>" 
    MsG = "?" 
    If InStr(1, UCase(txtOuvrTbl.Value), "SUM(") <> 0 Then 
        MsG = Mid(txtOuvrTbl.Value, InStr(1, UCase(txtOuvrTbl.Value), "SUM("), InStr(1, UCase(txtOuvrTbl.Value), ")") - InStr(1, UCase(txtOuvrTbl.Value), "SUM(")) 
    End If 
    If InStr(1, UCase(txtOuvrTbl.Value), "COUNT(") <> 0 Then 
        MsG = Mid(txtOuvrTbl.Value, InStr(1, UCase(txtOuvrTbl.Value), "COUNT("), InStr(1, UCase(txtOuvrTbl.Value), ")") - InStr(1, UCase(txtOuvrTbl.Value), "COUNT(")) 
    End If 
    If InStr(1, UCase(txtOuvrTbl.Value), "MAX(") <> 0 Then 
        MsG = Mid(txtOuvrTbl.Value, InStr(1, UCase(txtOuvrTbl.Value), "MAX("), InStr(1, UCase(txtOuvrTbl.Value), ")") - InStr(1, UCase(txtOuvrTbl.Value), "MAX(")) 
    End If 
    If InStr(1, UCase(txtOuvrTbl.Value), "MIN(") <> 0 Then 
        MsG = Mid(txtOuvrTbl.Value, InStr(1, UCase(txtOuvrTbl.Value), "MIN("), InStr(1, UCase(txtOuvrTbl.Value), ")") - InStr(1, UCase(txtOuvrTbl.Value), "MIN(")) 
    End If 
    If InStr(1, UCase(txtOuvrTbl.Value), "AVG(") <> 0 Then 
        MsG = Mid(txtOuvrTbl.Value, InStr(1, UCase(txtOuvrTbl.Value), "AVG("), InStr(1, UCase(txtOuvrTbl.Value), ")") - InStr(1, UCase(txtOuvrTbl.Value), "AVG(")) 
    End If 
    If MsG = "?" Then 
        For V = 0 To Rst.Fields.Count - 1: MsGPage = MsGPage & "<td>&nbsp" & Rst.Fields(V).Name & "&nbsp</td>": Next 
        Else 
        MsGPage = MsGPage & "<td>&nbsp" & MsG & ")&nbsp</td>" 
    End If 
    MsGPage = MsGPage & vbCrLf & "    </tr>" 
    'ajout de chaque lignes et valeur de chaque enregistrements 
    For V = 0 To Rst.RecordCount - 1 
        MsGPage = MsGPage & vbCrLf & "    <tr>" & vbCrLf & "        <td style=" & Chr(34) & "background-color:#E0E0E0;color:green" & Chr(34) & ">&nbsp" & V + 1 & "&nbsp</td>" 
        For T = 0 To Rst.Fields.Count - 1 
            'Rst.Fields(T) plante le programme pour les tables "MSysAccessObjects", provisoire  ********* a solutionner ************ 
            'MsgBox Rst.Fields(T).Type 
                        If Rst.Fields(T).Type = 205 Or Rst.Fields(T).Type = 204 then 'adLongVarBinary exemple 10101010, pour 204 adVarBinary >>> erreur 
                                If Rst.Fields(T).Type = 205 then 
                                        On Error Resume Next: MsGPage = MsGPage & "<td>" & Cstr(Rst.Fields(T).GetChunk(1024)) & "</td>" 
                                        If Err.Number <> 0 Then Err.Clear: MsGPage = MsGPage & "<td>?Err?</td>" 
                                        Else 
                                        'MsG = Rst.Fields(T): MsgBox MsG'  204 adVarBinary 
                                        On Error Resume Next: MsGPage = MsGPage & "<td>" & "???" & "</td>" 
                                        If Err.Number <> 0 Then Err.Clear: MsGPage = MsGPage & "<td>?Err?</td>" 
                                End If 
                                Else 
                                On Error Resume Next: MsGPage = MsGPage & "<td>" & Rst.Fields(T) & "</td>": If Err.Number <> 0 Then Err.Clear: MsGPage = MsGPage & "<td>?Err?</td>" 
                        End If 
        Next 
        MsGPage = MsGPage & vbCrLf & "    </tr>" 
        If V <> Rst.RecordCount - 1 Then Rst.MoveNext 
    Next 
    MsGPage = MsGPage & vbCrLf & "</table>" & vbCrLf & "</body>" 
    'msgbox "2 juste avant EnregJouerTbl" 
        EnregJouerTbl ExtratChem(DossierDuProg) & "\GenTblSpl.hta" 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub EnregJouerTbl(ChemNomFich) 
'cette Sub est utilisée par le bouton "Test+" et "Test++" après construction du tableau 
    'enregistre le fichier "GenTblSpl.hta" ou "GenTblMlt.hta" 
        'msgbox "avant création de la page HTML" & vbnewline & "ChemNomFich = " & ChemNomFich 
        Set Fso = CreateObject("Scripting.FileSystemObject") 
    Set F = Fso.OpenTextFile(ChemNomFich, ForWriting, True) 
    F.Write MsGPage 
    F.Close: Set F = Nothing: Set Fso = Nothing 
    'lance le fichier "GenTblSpl.hta" ou "GenTblMlt.hta" 
        'Sleep 1000  'tout compte fait je ne l'utilise pas 
        'msgbox "MsGPage = " & vbnewline & MsGPage 
    Set WshShell = CreateObject("WScript.Shell") 
        'msgbox "La page HTML vat être lancée " 
   If InStr(1, ChemNomFich, " ") Then 
        WshShell.Run Chr(34) & ChemNomFich & Chr(34) 
        Else 
        WshShell.Run ChemNomFich 
    End If 
    Set WshShell = Nothing 
        'msgbox "Page HTML lancée ?" 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub OuvreTbl() 
    Set Rst = Nothing 
    Set Rst = CreateObject("ADODB.Recordset") 
    On Error Resume Next 
        '***************** New du 26/10/2013 ***************** 
        If InStr(1, UCase(SQL), "EXCLURE", vbTextCompare) Then 
                SQL = FormatRqtSql(SQL) 
        End If 
        '***************** fin New du 26/10/2013 ***************** 
     
        If chkTbl.Checked Then SQL = VerifReqt(SQL) 
    
    Rst.Open SQL, Cnx, adOpenStatic, adLockPessimistic 
    If Err.Number <> 0 Then 
        MsG = "Erreur N°" & Err.Number & vbCrLf _ 
        & "Description:" & vbCrLf & Err.Description & vbCrLf _ 
        & "Impossible d'ouvrire la table" & vbCrLf _ 
        & "SQL = " & SQL 
        MsgBox MsG, vbCritical, "Erreur ouverture table" 
        Exit Sub 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
        '***************** New du 26/10/2013 ***************** 
Function FormatRqtSql(Reqt) 
        Dim LeftSql, RightSql, ExcludeChamp, ListeChamps 
        Dim LaReqtSQL 
        If TableNom(Reqt) <> NomDeLaTable Then 
                NomDeLaTable = TableNom(Reqt) 
                Dim RstTemp  
                Set RstTemp = CreateObject("ADODB.Recordset") 
                RstTemp.Open "Select * From " & NomDeLaTable, Cnx, adOpenStatic, adLockPessimistic 
                If RstTemp.state = adStateOpen Then 
                        Memo = "" 
                        For V = 1 To RstTemp.Fields.Count 
                                If V > 1 Then Memo = Memo & vbCrLf 
                                Memo = Memo & RstTemp.Fields(V - 1).Name 
                        Next 
                        RstTemp.Close: Set RstTemp = Nothing 
                End If 
                Else 
        End If 
        ListeChamps = Split(Memo, vbNewLine) 
  
        LaReqtSQL = Reqt 
  
        LeftSql = Trim(Left(LaReqtSQL, (InStr(1, UCase(LaReqtSQL), " FROM", vbTextCompare)))) 
        RightSql = Right(LeftSql, Len(LeftSql) - (InStr(1, UCase(LaReqtSQL), "EXCLURE", vbTextCompare) + 7)) 
        ExcludeChamp = Split(RightSql, ",") 
        RightSql = Trim(Right(LaReqtSQL, Len(LaReqtSQL) - (InStr(1, UCase(LaReqtSQL), " FROM", vbTextCompare) - 1))) 
        LeftSql = Trim(Left(LaReqtSQL, ((InStr(1, UCase(LaReqtSQL), "EXCLURE", vbTextCompare)) - 3))) 
        LeftSql = Replace(LeftSql, " *,", "") 
        If Len(LeftSql) < 9 Then LeftSql = Replace(LeftSql, "*", "") 
  
        For T = 0 To UBound(ListeChamps) 
                If InStr(1, LeftSql, ListeChamps(T), vbTextCompare) = 0 Then 
                        If Len(LeftSql) = 7 Then 
                                LeftSql = LeftSql & Trim(ListeChamps(T)) 
                                Else 
                                LeftSql = LeftSql & ", " & Trim(ListeChamps(T)) 
                        End If 
                End If 
        Next 
  
        For T = 0 To UBound(ExcludeChamp) 
                ExcludeChamp(T) = Trim(ExcludeChamp(T)) 
                LeftSql = Replace(LeftSql, ", " & ExcludeChamp(T), "") 
        Next 
        LaReqtSQL = LeftSql & " " & RightSql 
        FormatRqtSql = LaReqtSQL 
End Function 
'---------------------------------------------------------------------------------------------------------------------- 
Function TableNom(Reqt) 
        Deb = InStr(1, UCase(Reqt), " FROM ", vbTextCompare) + 7 
        Fin = InStr(Deb, Reqt, " ", vbTextCompare) 
        If Fin = 0 Then Fin = Len(Reqt) + 1 
        TableNom = Mid(Reqt, Deb - 1, (Fin - Deb) + 1) 
End Function 
        '***************** fin New du 26/10/2013 ***************** 
'---------------------------------------------------------------------------------------------------------------------- 
Sub TestChekDSN() 
    MiseAblanc 
    If chkBDsDSN.Checked Then 
        For V = 0 To LstDsn.length - 1 
            If LstDsn(V).Selected Then CheminNomDelabase = ChemNomBDsDSN(V): Exit For 
        Next 
        chkBDsFichier.Checked = "": LstDsn.disabled = "" 
        TypeBD = UCase(Right(CheminNomDelabase, InStr(1, StrReverse(CheminNomDelabase), ".", vbTextCompare) - 1)) 
                txtRqtConnx.Value = DefiniProvider(TypeBD) & ";Data Source=" & CheminNomDelabase & ";User Id=admin;Password=;" 
        Else 
        LstDsn.disabled = "disabled": txtRqtConnx.Value = "" 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub MiseAblanc() 
    txtOuvrTbl.Value = "": txtOuvrTbl.Title = "" 
    NbrTbl.Value = "0": NbrChamps.Value = "0" 
    For V = LstTbl.length To 0 Step -1: LstTbl.Remove (V): Next 'vide la liste tables 
    LstTbl.disabled = "disabled" 
    chkTbl.Checked = "": chkTbl.disabled = "disabled" 
    txtLstChamps.Value = "": txtLstChamps.disabled = "disabled" 
    BtTester2.disabled = "disabled": BtTester3.disabled = "disabled": BtTester4.disabled = "disabled" 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub TestChekFichier() 
    MiseAblanc 
    If chkBDsFichier.Checked Then 
        chkBDsDSN.Checked = "" 
        If NameBDs.Value = "" Then 
            MsgBox "Choisissez une BDs avec le bouton Parcourir ..", vbInformation, "BDs" 
            Else 
            If NameBDs.Value <> "" Then 
                                TypeBD = UCase(Right(NameBDs.Value, InStr(1, StrReverse(NameBDs.Value), ".", vbTextCompare) - 1)) 
                                txtRqtConnx.Value = DefiniProvider(TypeBD) & ";Data Source=" & NameBDs.Value & ";User Id=admin;Password=;" 
                        End If 
        End If 
        Else 
        txtRqtConnx.Value = "" 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub TestChekTbl() 
    If chkTbl.Checked Then 
        If NomDeLaTable <> LstTbl.Value Or txtOuvrTbl.Value = "" Then 
                        NomDeLaTable = LstTbl.Value: txtOuvrTbl.Value = "Select * From " & NomDeLaTable: txtOuvrTbl.Title = "" 
                End If 
                LstTbl.disabled = "": txtLstChamps.disabled = "" 
        RecupNomChamps 
        Else 
        LstTbl.disabled = "disabled": txtLstChamps.disabled = "disabled" 
        NomDeLaTable = "" 
    End If 
End Sub 
'+++++++++++++++++++++++++++++++++++++++++++++++ Partie formatage de la rêquete +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
Function VerifReqt(Req) 
'pour mettre entre [ et ] un nom de colonne ou un nom de table contenant un caractére engendrant une erreur, ICI le / et ~ et ' (a complèté peut être) 
Dim Deb, Pos, Cpt 
Dim NotCara(2) 
Dim MsgTemp 
  
NotCara(0) = "/": NotCara(1) = "~": NotCara(2) = "'" 
If Right(Req, 1) = ";" Then Req = Left(Req, Len(Req) - 1) 
VerifReqt = Req 
For Cpt = 0 To UBound(NotCara) 
    Pos = 1: MsgTemp = "" 
    If InStr(Pos, Req, NotCara(Cpt)) <> 0 Then 
        Do 
            Deb = -1 
            Pos = InStr(Pos, Req, NotCara(Cpt)) 
            Select Case Pos 
                 
                Case 0: Exit Do 'le caractère spécial n'est pas contenu dans la phrase 
             
                Case 1 'Bon **************** 
                    'le caractère spécial débute le mot et ce mot débute la phrase 
                    Deb = 1: MsgTemp = RecupMotDebute(Req, Deb, Len(Req)) 
                    Pos = Fin 
                Case Else 
                    If Pos > 1 then 
                                                If Mid(Req, Pos - 1, 1) = " " Then 'Bon ************ 
                                                        'le caractère spécial débute le mot mais pas la phrase 
                                                        Deb = Pos: MsgTemp = RecupMotDebute(Req, Deb, Len(Req)) 
                                                        Pos = Fin 
                                                        Else 
                                                        If Pos = Len(Req) Then 'Bon ************** 
                                                                'le caractère spécial finit le mot et la phrase 
                                                                Deb = 1: MsgTemp = RecupMotFinit(Req, Deb, Len(Req)) 
                                                                Pos = Fin 
                                                                Else 
                                                                If Mid(Req, Pos + 1, 1) = " " Or Mid(Req, Pos + 1, 1) = "," Then 'Bon ************** 
                                                                        'le caractère spécial finit le mot mais pas la phrase 
                                                                        Deb = 1: MsgTemp = RecupMotFinit(Req, Deb, Pos) 
                                                                        Pos = Pos + 1 
                                                                        Else 
                                                                        'le caractère spécial est contenu dans le mot 
                                                                        MsgTemp = RecupleMot(Req, Pos) 
                                                                        If NotCara(Cpt) = "'" Then 
                                                                                If left(MsgTemp,1) = "=" Or left(MsgTemp,1) = "<" Or left(MsgTemp,1) = ">"  Or left(MsgTemp,1) = " " Then 
                                                                                        Else 
                                                                                        Req = Replace(Req, MsgTemp, Replace(MsgTemp, "'", "''")) 
                                                                                End If 
                                                                        End If 
                                                                        Pos = Fin 
                                                                End If 
                                                        End If 
                                                End If 
                                        End IF 
            End Select 
            If NotCara(Cpt) <> "'" Then 
                If Left(MsgTemp, 1) = "#" Or Right(MsgTemp, 1) = "#" Then 
                    'cas particulier des DATEs 
                    Else 
                    Req = Replace(Req, MsgTemp, "[" & MsgTemp & "]") 
                    Req = Replace(Req, "[[", "[") 
                    Req = Replace(Req, "]]", "]") 
                End If 
            End If 
        Loop 
    End If 
Next 
Req = Replace(Req, "[[", "[") 
Req = Replace(Req, "]]", "]") 
VerifReqt = Req 
End Function 
'---------------------------------------------------------------------------------------------------------------------- 
Function RecupMotDebute(Reqt, Db, Fi) 
Dim Cpt0 
For Cpt0 = Db To Fi 
    If Mid(Reqt, Cpt0, 1) = " " Or Mid(Reqt, Cpt0, 1) = "," Then RecupMotDebute = Mid(Reqt, Db, Cpt0 - Db): Exit For 
Next 
If RecupMotDebute = "" Then RecupMotDebute = Mid(Reqt, Db, Len(Reqt) - (Db - 1)) 
Fin = Db + Len(RecupMotDebute) + 1 
End Function 
'---------------------------------------------------------------------------------------------------------------------- 
Function RecupMotFinit(Reqt, Db, Fi) 
Dim Cpt1 
For Cpt1 = Fi To Db Step -1 
    If Mid(Reqt, Cpt1, 1) = " " Or Mid(Reqt, Cpt1, 1) = "," Then RecupMotFinit = Mid(Reqt, Cpt1 + 1, Fi - Cpt1): Exit For 
Next 
If RecupMotFinit = "" Then RecupMotFinit = Mid(Reqt, Db, Fi - (Db - 1)) 
Fin = Len(Reqt) + 1 
End Function 
'---------------------------------------------------------------------------------------------------------------------- 
Function RecupleMot(Reqt, Posi) 
Dim Cpt2 
Dim MotGauche, MotDroite 
'<---< remonte la phrase 
For Cpt2 = Posi To 1 Step -1 
    If Mid(Reqt, Cpt2, 1) = " " Or Mid(Reqt, Cpt2, 1) = "," Then MotGauche = Mid(Reqt, Cpt2 + 1, Posi - Cpt2 - 1): Exit For 
Next 
If MotGauche = "" Then MotGauche = Mid(Reqt, 1, Posi - 1) 
'descend la phrase >---> 
For Cpt2 = Posi + 1 To Len(Reqt) 
    If Mid(Reqt, Cpt2, 1) = " " Or Mid(Reqt, Cpt2, 1) = "," Then MotDroite = Mid(Reqt, Posi + 1, Cpt2 - Posi - 1): Exit For 
Next 
If MotDroite = "" Then MotDroite = Mid(Reqt, Posi + 1, Len(Reqt) - Posi) 
RecupleMot = MotGauche & Mid(Reqt, Posi, 1) & MotDroite 
Fin = Posi + Len(MotDroite) + 1 
End Function 
'+++++++++++++++++++++++++++++++++++++++++++ Fin partie formatage de la rêquete +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
'---------------------------------------------------------------------------------------------------------------------- 
Function ExtratFichier(ChemNom) 
    Dim StrData, Pos 
    StrData = StrReverse(ChemNom) 
    Pos = InStr(1, StrData, "\", vbTextCompare) 
    StrData = Left(StrData, Pos - 1) 
    StrData = StrReverse(StrData) 
    ExtratFichier = StrData 
End Function 
'---------------------------------------------------------------------------------------------------------------------- 
Function ExtratChem(ChemNom) 
    ExtratChem = Left(ChemNom, Len(ChemNom) - InStr(1, StrReverse(ChemNom), "\", vbTextCompare)) 
End Function 
'---------------------------------------------------------------------------------------------------------------------- 
Sub tstBouton4() 
    If txtOuvrTbl.Value = "" Then 
        MsgBox "Le test d'ouverture de table ne peut être fait." & vbCrLf & "la boite de requête TABLE est vide", vbCritical, "Erreur" 
        Else 
        SQL = txtRqtConnx.Value 
        ConnBds 
        If Cnx.state = adStateOpen Then 
            SQL = txtOuvrTbl.Value 
            OuvreTbl 
            If Rst.state = adStateOpen Then 
                If Rst.EOF Then 
                    MsG = "Test Ok, mais aucun enregistrement disponnible" & vbCrLf 
                    MsgBox MsG, vbInformation, "Ouverture Table" 
                    Exit Sub 
                End If 
                NbrLgn = Int(NbrLgnTbl.Value) 
                If Rst.RecordCount > NbrLgn Then 
                    CreatTblMultiple 
                    Else 
                    CreatTbl 
                    Rst.Close: Set Rst = Nothing 
                    Cnx.Close: Set Cnx = Nothing 
                End If 
            End If 
        End If 
    End If 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub RecupeVBScript() 
    Const ForReading = 1 
    Set Fso = CreateObject("Scripting.FileSystemObject") 
    Set F = Fso.OpenTextFile(ChemFichierModel, ForReading) 
    ContenuLgn = Split(F.ReadAll, vbNewLine) 
    F.Close: Set F = Nothing 
    Set Fso = Nothing 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub CreatTblMultiple() 
Dim NumLgn, NbrPage, Ndeb, Nfin, NbrEnrg, ChemFichierTemp 
    ChemFichierModel = ExtratChem(DossierDuProg) & "\StructGenTbl.hta" 
    SQLConnect = txtRqtConnx.Value: SQLTbl = txtOuvrTbl.Value 
'********************************************************************************************************************** 
    RecupeVBScript 
    MsGPage = "" 
    For T = 0 To 2: MsGPage = MsGPage & ContenuLgn(T) & vbCrLf: Next 
    MsGPage = MsGPage & "       id =" & Chr(34) & "GenTblMlt" & Chr(34) & vbCrLf 
    MsGPage = MsGPage & "       applicationname =" & Chr(34) & "GenTblMlt" & Chr(34) & vbCrLf 
    MsGPage = MsGPage & "       ICON =" & Chr(34) & "MultiTBLHTA.ico" & Chr(34) & vbCrLf 
    For T = 6 To 62: MsGPage = MsGPage & ContenuLgn(T) & vbCrLf: Next 
    MsGPage = MsGPage & "ChemFichierTemp = " & Chr(34) & ExtratChem(DossierDuProg) & "\GenTblMlt.hta" & Chr(34) & vbCrLf 
    MsGPage = MsGPage & "NomDeLaBDs = " & Chr(34) & NomDeLaBDs & Chr(34) & ": NomDeLaTable = " & Chr(34) & NomDeLaTable & Chr(34) & vbCrLf 
    MsGPage = MsGPage & "SQLConnect = " & Chr(34) & SQLConnect & Chr(34) & vbCrLf 
    MsGPage = MsGPage & "SQLTbl = " & Chr(34) & SQLTbl & Chr(34) & vbCrLf 
    MsGPage = MsGPage & "AffNbrLgn = " & NbrLgn & vbCrLf 
    For T = 69 To 143: MsGPage = MsGPage & ContenuLgn(T) & vbCrLf: Next 
Set Cnx = CreateObject("ADODB.Connection") 
Cnx.CursorLocation = adUseClient: Cnx.Mode = adModeReadWrite 
  Cnx.Open SQLConnect 
Set Rst = CreateObject("ADODB.Recordset") 
  Rst.Open SQLTbl, Cnx, adOpenStatic, adLockPessimistic 
NbrEnrg = Rst.RecordCount 
  
'-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*- partie <body> -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*- 
'infos nom de la BDs, nom de la table, N° enregistrement debut et fin pour la page à afficher 
Ndeb = 0: Nfin = NbrLgn - 1: NumLgn = 144 
MsGPage = MsGPage & Left(ContenuLgn(NumLgn), (InStr(1, ContenuLgn(NumLgn), "NomBDs", vbTextCompare) - 1)) & NomDeLaBDs & Right(ContenuLgn(NumLgn), 5) & vbCrLf 
MsGPage = MsGPage & Left(ContenuLgn(NumLgn + 1), (InStr(1, ContenuLgn(NumLgn + 1), "NomTable", vbTextCompare) - 1)) & NomDeLaTable & Right(ContenuLgn(NumLgn + 1), 5) & vbCrLf 
MsGPage = MsGPage & Left(ContenuLgn(NumLgn + 2), (InStr(1, ContenuLgn(NumLgn + 2), "LaRequete", vbTextCompare) - 1)) & SQLTbl & Right(ContenuLgn(NumLgn + 2), 9) & vbCrLf 
MsGPage = MsGPage & Left(ContenuLgn(NumLgn + 3), (InStr(1, ContenuLgn(NumLgn + 3), "N°Deb", vbTextCompare) - 1)) & Ndeb + 1 & Right(ContenuLgn(NumLgn + 3), 5) & vbCrLf 
MsGPage = MsGPage & Left(ContenuLgn(NumLgn + 4), (InStr(1, ContenuLgn(NumLgn + 4), "N°Fin", vbTextCompare) - 1)) & Nfin + 1 & Right(ContenuLgn(NumLgn + 4), 5) & vbCrLf 
MsGPage = MsGPage & Left(ContenuLgn(NumLgn + 5), (InStr(1, ContenuLgn(NumLgn + 5), "NbrTotal", vbTextCompare) - 1)) & NbrEnrg & Right(ContenuLgn(NumLgn + 5), 10) & vbCrLf 
MsGPage = MsGPage & ContenuLgn(NumLgn + 6) & vbCrLf 
MsGPage = MsGPage & ContenuLgn(NumLgn + 7) & vbCrLf 
  
'---TABLEAU---, titrage colonnes avec les noms de champs 
MsGPage = MsGPage & "        <td>&nbsp&nbsp</td>" 
For V = 0 To Rst.Fields.Count - 1: MsGPage = MsGPage & "<td>&nbsp" & Rst.Fields(V).Name & "&nbsp</td>": Next 
MsGPage = MsGPage & vbCrLf & "    </tr>" 
  
'ajout de chaque lignes et valeur de chaque enregistrements 
Rst.Move Ndeb, AdBookmarkFirst 
U = Nfin - Ndeb 
For V = 0 To U 
        If Not Rst.EOF Then 
            MsGPage = MsGPage & vbCrLf & "    <tr>" & vbCrLf & "        <td style=" & Chr(34) & "background-color:#E0E0E0;color:green" & Chr(34) & ">&nbsp" & V + 1 & "&nbsp</td>" 
            For T = 0 To Rst.Fields.Count - 1 
                                If Rst.Fields(T).Type = 205 then 'adLongVarBinary exemple 10101010, pour 204 adVarBinary >>> erreur 
                                        On Error Resume Next: MsGPage = MsGPage & "<td>" & Cstr(Rst.Fields(T).GetChunk(1024)) & "</td>": If Err.Number <> 0 Then Err.Clear: MsGPage = MsGPage & "<td>?Err?</td>" 
                                        Else 
                                        On Error Resume Next: MsGPage = MsGPage & "<td>" & Rst.Fields(T) & "</td>": If Err.Number <> 0 Then Err.Clear: MsGPage = MsGPage & "<td>?Err?</td>" 
                                End If 
            Next 
            MsGPage = MsGPage & vbCrLf & "    </tr>" 
        End If 
        If Rst.EOF Then Exit For Else Rst.MoveNext 
Next 
Rst.Close: Set Rst = Nothing 
Cnx.Close: Set Cnx = Nothing 
'--- Liens pour appel des pages suivantes --- 
NbrPage = Int((NbrEnrg - 1) / NbrLgn) 
T = (NbrEnrg - 1) / NbrLgn 
If T > NbrPage Then NbrPage = NbrPage + 1 
MsGPage = MsGPage & vbCrLf & "  <tr style=" & Chr(34) & "background-color:#E0E0E0" & Chr(34) & ">" & vbCrLf 
MsGPage = MsGPage & "       <td colspan=" & Chr(34) & NbrPage & Chr(34) & ">" 
For V = 1 To NbrPage 
    If V = 1 Then 
        MsGPage = MsGPage & vbCrLf & "         <span style=" & Chr(34) & "color:#788C8C" & Chr(34) & ">" & V & "</span>" 
        Else 
        If V <> NbrPage Then 
            MsGPage = MsGPage & vbCrLf & "         <a id=" & Chr(34) & "Lien" & V & Chr(34) & " style=" & Chr(34) & "color:blue;text-Decoration:underline" & Chr(34) _ 
            & " Title=" & Chr(34) & "Enregistrements: " & (((V - 1) * NbrLgn) + 1) & "/" & (V * NbrLgn) & Chr(34) _ 
            & " onClick=" & Chr(34) & "NewPage " & ((V - 1) * NbrLgn) & "," & ((V * NbrLgn) - 1) & Chr(34) _ 
            & " onmouseover=" & Chr(34) & "MouseEnter(Lien" & V & ")" & Chr(34) _ 
            & " onmouseout=" & Chr(34) & "MouseExit(Lien" & V & ")" & Chr(34) _ 
            & ">" & V & "</a>" 
            Else 
            T = NbrEnrg 
            MsGPage = MsGPage & vbCrLf & "         <a id=" & Chr(34) & "Lien" & V & Chr(34) & " style=" & Chr(34) & "color:blue;text-Decoration:underline" & Chr(34) _ 
            & " Title=" & Chr(34) & "Enregistrements: " & (((V - 1) * NbrLgn) + 1) & "/" & T & Chr(34) _ 
            & " onClick=" & Chr(34) & "NewPage " & ((V - 1) * NbrLgn) & "," & T & Chr(34) _ 
            & " onmouseover=" & Chr(34) & "MouseEnter(Lien" & V & ")" & Chr(34) _ 
            & " onmouseout=" & Chr(34) & "MouseExit(Lien" & V & ")" & Chr(34) _ 
            & ">" & V & "</a>" 
        End If 
    End If 
Next 
V = UBound(ContenuLgn) - 4 
For T = V To UBound(ContenuLgn): MsGPage = MsGPage & vbCrLf & ContenuLgn(T): Next 
'-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*- fin partie <body> -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*- 
EnregJouerTbl ExtratChem(DossierDuProg) & "\GenTblMlt.HTA" 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
Sub TestNbrLgnTbl() 
    BtTester4.Title = "Avec affichage du résultat de la requête, par lot de " & NbrLgnTbl.Value & " enregistrements" 
End Sub 
'---------------------------------------------------------------------------------------------------------------------- 
</SCRIPT> 
  
<body style="margin: auto; margin-bottom: auto; margin-left: 10px; margin-right: 10px; margin-top: 10px;  
	background-color: #FDFDE5; background-position: center; background: url(Fond.jpg); background-repeat: no-repeat"> 
  
<!-- cartouche BDs (facultatif) --> 
	<select name="LstDsn" disabled="disabled" onchange="TestChekDSN"  
		style="position: absolute; left: 10px; top: 118px; height:22px; width:267px"> 
	<INPUT Type="checkbox" name="chkBDsDSN" disabled="disabled" onclick="TestChekDSN"  
		style="position: absolute; left: 286px; top: 124px; height:13px; width:13px"> 
	<INPUT Type="checkbox" name="chkBDsFichier" disabled="disabled" onClick="TestChekFichier"  
		style="position: absolute; left: 326px; top: 124px; height:13px; width:13px"> 
	<INPUT Type="file" name="NameBDs" title="Ouvrir une BDs" onchange="choixfichier"   
		style="background-color: white; position: absolute; left: 347px; top: 118px; height:22px; width:440px"> 
  
<!-- cartouche requête connexion à la BDs --> 
	<TEXTAREA name="txtRqtConnx"  onchange="VerifCnt" Value =""  
		style="background-color: powderblue; border-style: solid; position: absolute; left:12px; top: 226px; height:107px; width:707px"></TEXTAREA> 
	<INPUT Type="button" name="BtTester1" value="Tester" onClick="tstBouton1"  
		style="position: absolute; left: 724px; top: 309px; height:24px; width:58px"> 
  
<!-- cartouche requête table --> 
	<INPUT Type="checkbox" name="chkTbl"  disabled="disabled" onClick="TestChekTbl" title="Si coché, vérification/modification de la rédaction de la requête"  
		style="position: absolute; left: 283px; top: 384px; height:13px; width:13px"> 
	<SELECT name="LstTbl" disabled="disabled" onclick="TestChekTbl"  
		style="position: absolute; left: 304px; top: 378px; height: 22px; width:207px"></SELECT> 
	<TEXTAREA name="txtOuvrTbl" id="txtOuvrTbl" 
		style="background-color: lightgreen; border-style: solid; position: absolute; left:12px; top: 425px; height:107px; width:707px"></TEXTAREA> 
	<INPUT Type="button" name="NbrTbl" id="NbrTbl" 
		style="background-color: #CCFF9A; border-style: none; position: absolute; left:360px; top: 358px; height:18px; width:40px"> 
 	<TEXTAREA name="txtLstChamps" id="txtLstChamps" onmouseover="MouseEnter(txtLstChamps)" onmouseout="MouseExit(txtLstChamps)" disabled="disabled" 
		style="position:absolute; left:512px; top:378px; height:22px; width:208px"></TEXTAREA> 
	<INPUT Type="button" name="NbrChamps" id="NbrChamps" 
		style="background-color: #CCFF9A; border-style: none; position: absolute; left:645px; top: 358px; height:18px; width:30px"> 
	<INPUT Type="button" name="BtTester2" value="Tester" disabled="disabled" onClick="tstBouton2" title="Ne renseigne que sur le nombre d'enregistrements pouvant être retournée"  
		style="position: absolute; left: 724px; top: 425px; height:24px; width:58px"> 
	<INPUT Type="button" name="BtTester3" value="Test+" disabled="disabled" onClick="tstBouton3" title="Avec affichage du résultat de la requête sur une page" 
		style="position: absolute; left: 724px; top: 454px; height:24px; width:58px"> 
	<INPUT Type="button" name="BtTester4" value="Test++" disabled="disabled" onClick="tstBouton4" title="Avec affichage du résultat de la requête, par lot de 25 enregistrements" 
		style="position: absolute; left: 724px; top: 483px; height:24px; width:58px"> 
	<SELECT name="NbrLgnTbl"  onclick="TestNbrLgnTbl" title="Nbr. de lignes maximum par page tableau" 
		style="position: absolute; left: 724px; top: 508px; height:20px; width:58px"> 
		<OPTION VALUE="25">25 
		<OPTION VALUE="30">30 
		<OPTION VALUE="35">35 
		<OPTION VALUE="40">40 
		<OPTION VALUE="45">45 
		<OPTION VALUE="50">50 
		<OPTION VALUE="55">55 
		<OPTION VALUE="60">60 
		<OPTION VALUE="65">65 
		<OPTION VALUE="70">70 
		<OPTION VALUE="75">75 
		<OPTION VALUE="80">80 
		<OPTION VALUE="85">85 
		<OPTION VALUE="90">90 
		<OPTION VALUE="95">95 
		<OPTION VALUE="100">100 
	</SELECT> 
  
</body>
J'ai laissé plein de commentaires et MsgBox mis en commentaire, cela peut vous servir pour voir le déroulement du programme.
La structure reste la même.

 
Developpez.com décline toute responsabilité quant à l'utilisation des différents éléments téléchargés.