MS-Access - Industrialisation Zones listes (ListBox) en cascade avec en 1ère ligne Tous (All)
par
, 17/05/2016 à 15h58 (1405 Affichages)
Bonjour à tous,
Voici un exemple de code industrialisé pour alimenter en cascade des zones listes. Mon exemple porte sur 3 zones listes mais cette méthode à l'avantage d'être reproductible pour un nombre indéterminé de zones listes, il suffit de recopier le code de l'événement lst1_AfterUpdate sous chaque zone liste jusqu'à lst[IdxMax-1] avec les bons paramètres dans l'instance de clsParamLstBox et le tour est joué.
C'est parti et bon code!!!
Tables
3 tables
tblPere
{idPere libel
1 pere1
2 pere2}
tblPereFils
{idPere idFils libel
1 1 fils11
1 2 fils12
2 3 fils21
2 4 fils22}
tblPetitFils
{idFils idPetitFils libel
1 1 Petitfils11
1 2 Petitfils12
2 3 Petitfils21
2 4 Petitfils22}
IHM
Un formulaire "frmMain2" avec de 3 zones listes =>
Pour lst1 & lst2, lst3 les propriétés ci-dessous
- Nombre de colonnes: 3
- Largeur des colonnes: 0,5cm;0,5cm;3cm
- Colonne liée :2
- Sélection multiple : simple
Pour List1
Contenu: qryPere
Origine source : table/requête
Requêtes
qryPere
Editeur VBA
Code SQL : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4 SELECT tblPere.idPere as idPere0,tblPere.idPere, tblPere.libel FROM tblPere UNION SELECT "all" as idPere0, "all" as idPere, "<All>" as libel FROM tblPere ORDER BY idPere DESC;
module mZoneListe
Code VBA : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105 Option Compare Database Public Type clsParamLstBox frmName As String lstSelected As Integer lstSourceTable As String lstSourceId As String lstSourceIdx As Integer lstCibleTable As String lstCibleId As String End Type Public Function displayListBox(myClsParamLstBox As clsParamLstBox) On Error GoTo Err_ Dim sSQL As String, sValues As String Dim sLstNameCible As String sValues = selectedItems(myClsParamLstBox) With myClsParamLstBox sLstNameCible = "lst" & .lstSelected + 1 sSQL = "SELECT " & .lstSourceId & "," & .lstCibleId & ", libel FROM " & .lstCibleTable & _ IIf(sValues = "all" Or sValues = "", "WHERE " & .lstSourceId & " IN (-1)", " WHERE " & .lstSourceId & " IN (" & sValues & ")") & _ " UNION SELECT 'all' AS " & .lstSourceId & ", 'all' AS " & .lstCibleId & ", '<All>' AS libel FROM " & .lstCibleTable & _ " ORDER BY libel ASC" Forms(.frmName).Controls(sLstNameCible).RowSource = sSQL Forms(.frmName).Controls(sLstNameCible).Selected(0) = True End With Exit_: Exit Function Err_: MsgBox Err.Description Resume Exit End Function Function selectedItems(myClsParamLstBox As clsParamLstBox) As String On Error GoTo Err_ Dim sSelectedItems As String, sValue As String Dim lstName As String Dim sLastSelectedItem As String With myClsParamLstBox lstName = "lst" & .lstSelected Set lstObj = Forms(.frmName).Controls(lstName) sSelectedItems = "" sLastSelectedItem = "" If lstObj.Selected(0) = True Then For i = 1 To lstObj.ListCount - 1 If sLastSelectedItem <> lstObj.Column(1, i) Then sSelectedItems = sSelectedItems & IIf(sSelectedItems = "", lstObj.Column(1, i), "," & lstObj.Column(1, i)) Next i selectedItems = sSelectedItems Else For Each idxItem In lstObj.ItemsSelected sSelectedItems = sSelectedItems & IIf(sSelectedItems = "", lstObj.ItemData(idxItem), "," & lstObj.ItemData(idxItem)) Next idxItem selectedItems = sSelectedItems End If End With Exit_: Exit Function Err_: MsgBox Err.Description Resume Exit_ End Function Function selectAll(myClsParamLstBox As clsParamLstBox) On Error GoTo Err_ Dim i As Integer Dim sLstName As String With myClsParamLstBox sLstName = "lst" & .lstSelected Set lstObj = Forms(.frmName).Controls(sLstName) If .lstSourceIdx = 0 Or .lstSourceIdx = -1 Then For Each idxItem In lstObj.ItemsSelected If idxItem > 0 Then lstObj.Selected(idxItem) = False Next idxItem Else lstObj.Selected(0) = False End If End With Exit_: Exit Function Err_: MsgBox Err.Description Resume Exit_ End Function
Dans le formulaire
Code VBA : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69 Private Sub Form_Load() On Error GoTo Err_ Me.lst1.Selected(0) = True Me.lst1.SetFocus call lst1_AfterUpdate Exit_: Exit Sub Err_: MsgBox Err.Description Resume Exit_ End Sub Private Sub lst1_AfterUpdate() On Error GoTo Err_ Dim idxSelected As Integer Dim sFuncName As String With myClsParamLstBox .frmName = "frmMain2" .lstSelected = 1 .lstSourceId = "idPere" .lstSourceTable = "tblPere" .lstCibleTable = "tblPereFils" .lstCibleId = "idFils" .lstSourceIdx = Me.lst1.ListIndex Call selectAll(myClsParamLstBox) Call displayListBox(myClsParamLstBox) Me.Controls("lst" & .lstSelected + 1).Selected(0) = True Call lst2_AfterUpdate End With Exit_: Exit Sub Err_: MsgBox Err.Description Resume Exit_ End Sub Private Sub lst2_AfterUpdate() On Error GoTo Err_ Dim myClsParamLstBox As clsParamLstBox Dim idxSelected As Integer Dim sFuncName As String With myClsParamLstBox .frmName = "frmMain2" .lstSelected = 2 .lstSourceId = "idFils" .lstSourceTable = "tblPereFils" .lstCibleTable = "tblPetitFils" .lstCibleId = "idPetitFils" .lstSourceIdx = Me.lst2.ListIndex Call selectAll(myClsParamLstBox) Call displayListBox(myClsParamLstBox) Me.Controls("lst" & .lstSelected + 1).Selected(0) = True
![]()