Salut
Bien qu'Excel ne soit pas fait pour être utilisé comme une base de donnée, nous sommes nombreux(ses) à l'utiliser comme tel. Ainsi l'affichage et la modification de la base de donnée sont réalisées dans le meilleur des cas à l'aide de UserForms.
Je me suis attelé à un ensemble de 4 modules de classe permettant d'automatiser tout ça.
Le projet n'est pas terminé mais suffisamment fonctionnel pour être utilisé tel quel, je le pose donc ici à l'épreuve de vos remarques
Voici les différents codes contenus dans les modules
Module de Classe :
Cls_Data
Cls_DataFields
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425 Option Explicit 'Todo : Des procédures de comparaison pour trouver des doublons 'Todo : Une procédure pseudo SQL pour faire des tris? 'Todo : Remplacer les opt individuelles par une enumération '################################################# Public Enum Enum_OptionDataModule opt_CompareDataToCtrlBeforeUpdate = 1 opt_ColorControlIfNeededIsEmpty = 2 opt_AddingInListIfDataValueAbsent = 4 opt_ColorControlIfDataValueAbsent = 8 End Enum '################################################# 'Constructeur Event Initialize() 'x Event Terminate() 'x 'Evenements Field Event CtrlChange(theLinker As Cls_Linker) 'x 'Event DataChange(theField As Cls_DataField) 'Evenements Globaux Event BeforeCtrlUpdate(theField As Cls_DataField, isGlobalUpdate As Boolean) 'x Event BeforeDataUpdate(theField As Cls_DataField, isGlobalUpdate As Boolean) 'x Event AfterCtrlUpdate(theField As Cls_DataField, isGlobalUpdate As Boolean, isCorrect As Boolean) 'x Event AfterDataUpdate(theField As Cls_DataField, isGlobalUpdate As Boolean, isCorrect As Boolean) 'x Event BeforeUpdateGeneralData() Event BeforeUpdateGeneralCtrl() Event AfterUpdateGeneralData(isCorrect As Boolean) Event AfterUpdateGeneralCtrl(isCorrect As Boolean) Event BeforeRowDeleting(RowIndex As Long) 'x Event AfterRowDeleting() 'x Event BeforeRowAdding() 'x Event AfterRowAdding(RowIndex As Long) 'x Event BeforeActiveRowChange(ActuelRowIndex As Long, FuturRowIndex As Long) 'x Event AfterActiveRowChange(OldRowIndex As Long, NewRowIndex As Long) 'x Event CtrlLinkCreate(theLinker As Cls_Linker) '################################################# 'Private WithEvents Ws_Data As Worksheet Private pTab_Data As ListObject Private pActiveRowIndex As Long Private pParent As UserForm Private pDataFields As Cls_DataFields Private pListeCtrl As Variant Private pTxtBox_Index As MSForms.TextBox Private pDeletingRow As Boolean 'Options Private pOptions As Enum_OptionDataModule Private Const pListe_LigneCtrl As Integer = 1 Private Const pListe_LigneColumn As Integer = 2 Private Const pListe_LigneNeeded As Integer = 3 Private Const pListe_LigneTrueVal As Integer = 4 Private Const pListe_LigneFalseVal As Integer = 5 '################################################# Public Sub InitDataStructur(aParent As UserForm, aDataSource As ListObject) Set Parent = aParent Set Tab_Data = aDataSource 'On pointe la feuille contenant le tableau structuré 'If Not Tab_Data Is Nothing Then Set Ws_Data = Tab_Data.TableObject End Sub Private Sub Class_Initialize() 'On crée la collection de la liste de champs Set pDataFields = New Cls_DataFields pDataFields.InitFields Me 'On déclenche un évènement RaiseEvent Initialize End Sub Private Sub Class_Terminate() 'On déclenche un évènement RaiseEvent Terminate 'On détruit les objets Set pDataFields = Nothing End Sub '################################################# Friend Property Let ActiveRowIndex(Index As Long) 'On passe au Row indiqué pActiveRowIndex = Index 'On met à jour les controle pDataFields.UpdateAllControls 'On met à jour le textbox index s'il existe If Not pTxtBox_Index Is Nothing Then pTxtBox_Index.Text = Index End Property Public Property Set TxtBox_Index(aTextBox As MSForms.TextBox) Set pTxtBox_Index = aTextBox 'On interdit sa modification manuel aTextBox.Locked = True 'On met à jour aTextBox.Text = CStr(pActiveRowIndex) End Property Public Property Get TxtBox_Index() As MSForms.TextBox Set TxtBox_Index = pTxtBox_Index End Property Public Property Let Options(aValue As Enum_OptionDataModule) pOptions = aValue End Property Public Property Get Options() As Enum_OptionDataModule Options = pOptions End Property Public Property Get Fields() As Cls_DataFields Set Fields = pDataFields End Property Public Property Get Tab_Data() As ListObject Set Tab_Data = pTab_Data End Property Public Property Set Tab_Data(ByRef aTab_Data As ListObject) Dim iCol As Integer Set pTab_Data = aTab_Data 'todo:Refaire les fields 'On vide la collection pDataFields.Clear 'On crée les fields If Not pTab_Data Is Nothing Then 'On boucle sur les colonne For iCol = 1 To pTab_Data.ListColumns.Count 'On ajoute le field pDataFields.AddNewField pTab_Data.ListColumns(iCol) Next 'On pointe la 1ère ligne si existante Me.MoveToFirstRow 'On lie les Ctrl CreateCtrlLink 'On met à jour les controls pDataFields.UpdateAllControls 'On défini l'activeRow 'If pTab_Data.ListRows.Count < 0 Then Set pActiveRow = pTab_Data.ListRows(1) End If End Property Public Property Let ListeLinkedCtrl(tableau As Variant) 'Si le tableau/range 'contient de 1 à 4 ligne(s) 'la 1ère doit contenir le nom du ctrl associé 'la seconde le nom des colonnes (si omis les numéros de colonne seront utilisés dans l'orde) '3ème indique si un contenu est obligatoire 'les 4ème et 5ème Pour les chkBox :contiennent les valeurs concidérées comme étant True et False (Valeurs séparées par des ";") '--------------------------------------------------------- 'On transforme le range/tableau en tableau interne 'On place le tableau en mémoire pListeCtrl = tableau 'On renseigne les ctrl liés CreateCtrlLink End Property Public Property Get ListeLinkedCtrl() As Variant ListeLinkedCtrl = pListeCtrl End Property 'Lecture seul Public Property Get ActiveRow() As ListRow If pActiveRowIndex <> 0 Then Set ActiveRow = pTab_Data.ListRows(pActiveRowIndex) End Property Public Property Get Parent() As UserForm Set Parent = pParent End Property Public Property Set Parent(ByRef aParent As UserForm) Set pParent = aParent End Property Public Property Get RowCount() As Long RowCount = pDataFields.Count End Property '################################################# Private Sub CreateCtrlLink() Dim iCol As Integer, iLinkedCol As Integer Dim aCtrl As MSForms.Control, aField As Cls_DataField 'On vérifie que pListeCtrl s'agit bien d'un tableau If Not IsEmpty(pListeCtrl) Then If IsArray(pListeCtrl) Then If UBound(pListeCtrl) <> -1 Then 'On boucle sur les colonnes du tableau ctrl For iCol = 1 To UBound(pListeCtrl, 2) 'On réinitialise les valeurs iLinkedCol = -1 Set aCtrl = Nothing Set aField = Nothing On Error Resume Next 'On cherche l'indice de la colonne correspondante iLinkedCol = pTab_Data.ListColumns(pListeCtrl(pListe_LigneColumn, iCol)).Index 'Si introuvable (vide ou erroné) If iLinkedCol = -1 Then 'Todo : Traiter erreur iLinkedCol = iCol End If 'On recherche le field correspodnant Set aField = pDataFields.Field(pTab_Data.ListColumns(iLinkedCol)) 'On pointe le ctrl If Not IsEmpty(pListeCtrl(pListe_LigneCtrl, iCol)) Then Set aCtrl = pParent.Controls(pListeCtrl(pListe_LigneCtrl, iCol)) On Error GoTo 0 'On vérifie que le field existe If Not aField Is Nothing Then 'On renseigne les valeurs "Vrai" et "False" 'On regarde si la 3ème ligne existe If UBound(pListeCtrl) > pListe_LigneColumn Then aField.IsNeeded = pListeCtrl(pListe_LigneNeeded, iCol) 'On regarde si la 4ème existe If UBound(pListeCtrl) > pListe_LigneNeeded Then aField.ConformTrueValues = pListeCtrl(pListe_LigneTrueVal, iCol) 'On regarde si la 5ème existe If UBound(pListeCtrl) > pListe_LigneTrueVal Then aField.ConformFalseValues = pListeCtrl(pListe_LigneFalseVal, iCol) 'On pointe le ctrl Set aField.LinkedCtrl = aCtrl RaiseEvent CtrlLinkCreate(aField.Linker) Else 'Todo : Traiter End If Next 'On fait une mise à jour pDataFields.UpdateAllControls End If End If End If End Sub Public Sub MoveToNextRow() 'On vérifie que le listObject est lié If Not pTab_Data Is Nothing Then 'S'il y a au moins un Row devant, on le pointe MoveToRow pActiveRowIndex + 1 End If End Sub Public Sub MoveToPreviousRow() 'On vérifie que le listObject est lié If Not pTab_Data Is Nothing Then 'S'il y a au moins un Row derrière, on le pointe MoveToRow pActiveRowIndex - 1 End If End Sub Public Sub MoveToFirstRow() 'On vérifie que le listObject est lié If Not pTab_Data Is Nothing Then 'S'il y a au moins un Row derrière, on le pointe MoveToRow 1 End If End Sub Public Sub MoveToLastRow() 'On vérifie que le listObject est lié If Not pTab_Data Is Nothing Then 'S'il y a au moins un Row derrière, on le pointe MoveToRow pTab_Data.ListRows.Count End If End Sub Public Sub MoveToRow(Index As Long, Optional ForceOut As Boolean = False) Dim Cancel As Boolean, GoUpdateData As Boolean Dim OldIndex As Long 'On vérifie que le listObject est lié If Not pTab_Data Is Nothing Then 'On vérifie que le nouvel index fait partie de la plage If (pTab_Data.ListRows.Count >= Index) And ((Index > 0) Or ForceOut) Then 'On regarde si des modifs ont été apportés et s'il ne s'agit pas du 1er chargement (0) 'S'il y a des différence mais que l'on ne gére pas dans le module de classe, les données non engegistrées sont de facto perdues 'pCompareDataToCtrl If pDataFields.IsAllDataCtrlDifferent And (pActiveRowIndex <> 0) And CBool(Options And opt_CompareDataToCtrlBeforeUpdate) And Not pDeletingRow Then 'On demande ce que l'utilisateur veut faire pDataFields.AskSave Cancel, GoUpdateData End If 'On regarde si les données doivent être enregistrées If GoUpdateData Then Cancel = Not pDataFields.UpdateAllData 'On pointe la nouvelle ligne If Not Cancel Then 'On mémorise le row actuel OldIndex = pActiveRowIndex RaiseEvent BeforeActiveRowChange(pActiveRowIndex, Index) 'On change le pointeur de place ActiveRowIndex = Index RaiseEvent AfterActiveRowChange(OldIndex, pActiveRowIndex) End If End If End If End Sub Public Function AddRow(Optional ActivateRow As Boolean = False) As ListRow 'On ajoute une ligne RaiseEvent BeforeRowAdding Set AddRow = pTab_Data.ListRows.Add RaiseEvent AfterRowAdding(AddRow.Index) If ActivateRow Then MoveToRow AddRow.Index End Function Public Function DeleteRow(Index As Long) As Boolean 'On regarde si l'index existe-> On laisse la gestion s'en occuper? If Index <= RowCount Then 'On informe que la destruction de cette ligne est en cours pDeletingRow = True 'On vérifie que l'index du row actif ne se retrouvera pas en dehors de la plage une fois le row supprimé If pActiveRowIndex = RowCount Then MoveToPreviousRow 'On regarde si le row à supprimer est le row actif If Index = pActiveRowIndex Then 'On vérifie que le tableau contienne plus d'un row If RowCount = 1 Then MoveToRow 0, True pDataFields.UpdateAllControls End If End If 'On supprime le Row RaiseEvent BeforeRowDeleting(Index) pTab_Data.ListRows(Index).Delete DeleteRow = True RaiseEvent AfterRowDeleting 'On met à jour pDataFields.UpdateAllControls pDeletingRow = False Else 'todo : Traitement End If End Function '################################################# 'Evènements Friend Sub LinkedControlChange(Linker As Cls_Linker) RaiseEvent CtrlChange(Linker) End Sub Friend Sub Event_UpdateField(theField As Cls_DataField, isBefore As Boolean, isCtrl As Boolean, isGlobal As Boolean, Optional isCorrect As Boolean) 'On génère l'évènement If isBefore Then If isCtrl Then RaiseEvent BeforeCtrlUpdate(theField, isGlobal) Else RaiseEvent BeforeDataUpdate(theField, isGlobal) End If Else If isCtrl Then RaiseEvent AfterCtrlUpdate(theField, isGlobal, isCorrect) Else RaiseEvent AfterDataUpdate(theField, isGlobal, isCorrect) End If End If End Sub Friend Sub Event_GeneralUpadte(isBefore As Boolean, isCtrl As Boolean, Optional isCorrect As Boolean) If isBefore Then If isCtrl Then RaiseEvent BeforeUpdateGeneralCtrl Else RaiseEvent BeforeUpdateGeneralData End If Else If isCtrl Then RaiseEvent AfterUpdateGeneralCtrl(isCorrect) Else RaiseEvent AfterUpdateGeneralData(isCorrect) End If End If End Sub Friend Sub Event_ErrorOccurred() End Sub
Cls_DataField
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149 Option Explicit 'https://www.developpez.net/forums/d1809277/logiciels/microsoft-office/general-vba/definir-propriete-defaut-d-classe-personnalisee-vba/ Private pFieldsCollection As Collection Private pDataModule As Cls_Data '################################################# Private Sub Class_Initialize() Set pFieldsCollection = New Collection End Sub Private Sub Class_Terminate() Set pFieldsCollection = Nothing End Sub '################################################# Public Property Get Count() As Integer Count = pFieldsCollection.Count End Property Public Property Set DataModule(aDataModule As Cls_Data) Set pDataModule = aDataModule End Property Public Property Get DataModule() As Cls_Data Set DataModule = pDataModule End Property Public Property Get IsAllDataCtrlDifferent() As Boolean Dim iField As Integer 'On comparer la value actuelle des controls et les valeurs dans la base iField = 1 Do Until (iField = Count + 1) Or IsAllDataCtrlDifferent IsAllDataCtrlDifferent = Me.Field(iField).IsDataCtrlDifferent iField = iField + 1 Loop End Property Public Property Get Field(Index As Variant) As Cls_DataField '{Attribute Value.VB_UserMemId = 0} ' Todo: A Ajouter au bloc note 'On transmet le field correspondant Set Field = pFieldsCollection.Item(Index) End Property Public Property Get IfAllNeededNotEmpty() As Boolean Dim iField As Integer 'On regarde dans chaque Field IfAllNeededNotEmpty = True iField = 1 Do Until (iField = Count + 1) Or Not IfAllNeededNotEmpty IfAllNeededNotEmpty = Me.Field(iField).IfNeededNotEmpty iField = iField + 1 Loop End Property '################################################# Friend Function AddNewField(aColumn As ListColumn) As Cls_DataField Dim aField As Cls_DataField 'On crée un nouveau champs Set aField = New Cls_DataField 'Initialisation des valeurs aField.InitField Me, aColumn:=aColumn 'On le place dans la collection pFieldsCollection.Add aField, aColumn.Name 'On retourne le nouveau Field Set AddNewField = Field(aColumn.Name) 'On détruit Set aField = Nothing End Function Friend Function AskSave(ByRef Cancel As Boolean, ByRef GoUpdateX As Boolean) As VbMsgBoxResult AskSave = MsgBox("Des modifications n'ont pas encore été enregistrées, souhaitez-vous les enregistrer? Dans le cas contraire les modifications seront perdues", vbYesNoCancel, "Enregistrer les modifications?") 'On traite le retour Cancel = (AskSave = vbCancel) Or (AskSave = vbAbort) GoUpdateX = (AskSave = vbYes) End Function Public Function UpdateAllData() As Boolean Dim iField As Integer, Retour As Boolean 'Init UpdateAllData = True 'On vérifie que tous les champs obligatoire sont renseignés If IfAllNeededNotEmpty Then 'Evenement BeforeGeneralUpdate pDataModule.Event_GeneralUpadte True, False For iField = 1 To Count If Field(iField).IsReadyToUse Then 'On fait une mise à jour en précisant son statut comme global Retour = Me.Field(iField).UpdateData(True) 'On ne conserve qu'un echec If Not Retour Then UpdateAllData = False End If Next 'Evenement AfterGeneralUpdate pDataModule.Event_GeneralUpadte False, False, UpdateAllData Else 'Todo : Traitement tous les champs obligatoires ne sont pas renseignés MsgBox "Les champs obligatoires doivent être renseignés pour pouvoir être enregistrés." & IIf(CBool(pDataModule.Options And opt_ColorControlIfNeededIsEmpty), Chr(13) & "Veuillez renseigner les controls rouges.", ""), vbExclamation, "Contrôle(s) obligatoire(s) non renseigné(s)" UpdateAllData = False End If End Function Public Function UpdateAllControls() As Boolean Dim iField As Integer, Retour As Boolean pDataModule.Event_GeneralUpadte True, True For iField = 1 To Count If Field(iField).IsReadyToUse Then 'On fait une mise à jour en précisant son statut comme global Retour = Me.Field(iField).UpdateCtrl(True) 'On ne conserve qu'un echec If Not Retour Then UpdateAllControls = False End If Next pDataModule.Event_GeneralUpadte False, True, UpdateAllControls End Function Public Sub Clear() Dim iField As Integer For iField = Count - 1 To 0 Step -1 pFieldsCollection.Remove iField Next End Sub Public Sub InitFields(aDataModule As Cls_Data) Set pDataModule = aDataModule End Sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175 Option Explicit '################################################# Private pParent As Cls_DataFields Private pLinkerCtrl As Cls_Linker Private pLinkedColumn As ListColumn Private pCommaListTrueValues As String, pCommaListFalseValues As String Private pIsNeeded As Boolean '################################################# Private Sub Class_Initialize() Set pLinkerCtrl = New Cls_Linker Set pLinkerCtrl.Parent = Me End Sub Private Sub Class_Terminate() Set pLinkerCtrl = Nothing End Sub Public Sub InitField(aParent As Cls_DataFields, Optional aControl As MSForms.Control, Optional aColumn As ListColumn) Set Parent = aParent If Not IsMissing(aControl) Then Set pLinkerCtrl.LinkedControl = aControl If Not IsMissing(aColumn) Then Set pLinkedColumn = aColumn End Sub '################################################# Private Property Set Parent(aParent As Cls_DataFields) 'Changement de parent impossible une fois défini If pParent Is Nothing Then Set pParent = aParent End Property Public Property Get Linker() As Cls_Linker Set Linker = pLinkerCtrl End Property Public Property Get DataValue() As Variant 'Retourne la valeur contenu dans la base With pParent.DataModule If Not .ActiveRow Is Nothing Then DataValue = .ActiveRow.Range(1, pLinkedColumn.Index) End With End Property Public Property Let DataValue(aValue As Variant) With pParent.DataModule If Not .ActiveRow Is Nothing Then .ActiveRow.Range(1, pLinkedColumn.Index) = aValue End With End Property Public Property Get IsDataCtrlDifferent() As Boolean If Not pLinkerCtrl Is Nothing Then IsDataCtrlDifferent = Not pLinkerCtrl.EquivValue(DataValue) ' <> LinkedCtrl.Value End Property Public Property Get Parent() As Cls_DataFields Set Parent = pParent End Property Public Property Set LinkedCtrl(aControl As Control) Set pLinkerCtrl.LinkedControl = aControl 'On met à jour le contenu du control Me.UpdateCtrl End Property Public Property Get LinkedCtrl() As Control Set LinkedCtrl = pLinkerCtrl.LinkedControl End Property Public Property Let ConformTrueValues(aCommaList As String) pCommaListTrueValues = aCommaList End Property Public Property Get ConformTrueValues() As String ConformTrueValues = pCommaListTrueValues End Property Public Property Let ConformFalseValues(aCommaList As String) pCommaListFalseValues = aCommaList End Property Public Property Get ConformFalseValues() As String ConformFalseValues = pCommaListFalseValues End Property Public Property Get LinkedColumn() As ListColumn Set LinkedColumn = pLinkedColumn End Property Public Property Set LinkedColumn(aLinkedColumn As ListColumn) Set pLinkedColumn = aLinkedColumn End Property Public Property Get IsReadyToUse() As Boolean 'On vérifie que le linker est les deux infos principales (Colonne et Controle) IsReadyToUse = Not ((pLinkedColumn Is Nothing) Or (pLinkerCtrl Is Nothing)) End Property Public Property Get IsNeeded() As Boolean IsNeeded = pIsNeeded End Property Public Property Let IsNeeded(aValue As Boolean) pIsNeeded = aValue End Property Public Property Get IfNeededNotEmpty() As Boolean IfNeededNotEmpty = (IsNeeded And (pLinkerCtrl.Value <> vbNullString)) Or Not IsNeeded End Property '################################################# 'Friend Sub ForceNewParent(aParent As Cls_DataFields) ' Set pParent = aParent 'End Sub Public Function UpdateCtrl(Optional GlobalUpdate As Boolean) As Boolean Parent.DataModule.Event_UpdateField Me, True, True, GlobalUpdate pLinkerCtrl.Value = DataValue UpdateCtrl = Not Me.IsDataCtrlDifferent Parent.DataModule.Event_UpdateField Me, False, True, GlobalUpdate, UpdateCtrl End Function Public Function UpdateData(Optional GlobalUpdate As Boolean) As Boolean Parent.DataModule.Event_UpdateField Me, True, False, GlobalUpdate 'On vérifie que les renseignement obligatoire sont bien renseigné If (pLinkerCtrl.Value = vbNullString) And IsNeeded Then 'Todo : Traitement valeur null pour une valeur obligatoire Else '(pLinkerCtrl.Value <> vbNullString) Or Not IsNeeded Then DataValue = pLinkerCtrl.Value UpdateData = Not Me.IsDataCtrlDifferent End If Parent.DataModule.Event_UpdateField Me, False, False, GlobalUpdate, UpdateData End Function Public Function ValeursUniques() As Variant 'Retour une liste contenant toutes les valeur de la colonne sans doublon Dim iSource As Long, iDest As Long Dim tab_Val As Variant 'Init ValeursUniques = "¤" 'On place le contenu de la colonne dans une tableau interne tab_Val = pLinkedColumn.DataBodyRange 'On boucle sur les valeurs For iSource = 1 To UBound(tab_Val) 'On exclue les chaines vides If tab_Val(iSource, 1) <> vbNullString Then If InStr(1, ValeursUniques, "¤" & tab_Val(iSource, 1) & "¤", vbTextCompare) = 0 Then 'Le mot n'existe pa, on l'ajoute ValeursUniques = ValeursUniques & tab_Val(iSource, 1) & "¤" End If End If Next 'On nettoie le résultat 'On supprime le 1er caractère de la chaine ("¤") ValeursUniques = Right(ValeursUniques, Len(ValeursUniques) - 1) 'On supprime le "¤" final If ValeursUniques <> vbNullString Then ValeursUniques = Left(ValeursUniques, Len(ValeursUniques) - 1) 'On crée le tableau de valeurs ValeursUniques = Split(ValeursUniques, "¤") End Function
Cls_Linker
Cls_Data :représente la structure de la Base de donnée adossée à un tableau structuré (TS). L'instance sera déclarée au sein d'un UserForm ou d'un Module.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362 Option Explicit 'But : lier withevent un objet control indépendament de son type Private WithEvents TxtB As MSForms.TextBox Private WithEvents ChkB As MSForms.CheckBox Private WithEvents CboB As MSForms.ComboBox Private WithEvents LstB As MSForms.ListBox Private WithEvents Lbl As MSForms.Label Private pGenericControl As MSForms.Control Private pParent As Cls_DataField Private pDefautEnCours As Long Private Color_Defaut As OLE_COLOR Private Const CstColor_Red = &HC0C0FF 'Champs obligatoire vide Private Const CstColor_Vio = &HFFC0C0 'Champs ne contenant pas les entrées necessaires pour correspondre aux data '################################################# '################################################# 'Les options Private Property Get Options() As Enum_OptionDataModule Options = Parent.Parent.DataModule.Options End Property Friend Property Set Parent(aFieldParent As Cls_DataField) Set pParent = aFieldParent End Property Public Property Get Parent() As Cls_DataField Set Parent = pParent End Property Public Property Get LinkedControl() As MSForms.Control Set LinkedControl = pGenericControl End Property Public Property Get TypeCtrl() As String TypeCtrl = TypeName(pGenericControl) End Property Public Property Set LinkedControl(aControl As MSForms.Control) Set pGenericControl = aControl 'On transtype control Select Case LCase(TypeName(pGenericControl)) Case "label" Set Lbl = pGenericControl Case "textbox" Set TxtB = pGenericControl Case "checkbox" Set ChkB = pGenericControl Case "optionbutton" 'On va boucler sur tous les option boutton de la page et repérer les groupenames pour trouver la valeur Case "combobox" Set CboB = pGenericControl Case "listbox" Set LstB = pGenericControl Case Else 'Todo : Traitement End Select 'On mémorise la couleur par défaut If Not pGenericControl Is Nothing Then Color_Defaut = pGenericControl.BackColor 'On applique la coloration ColorationBack End If End Property Public Property Get Value() As Variant Dim iList As Integer, iCol As Byte 'On retourne le contenu Select Case LCase(TypeName(pGenericControl)) Case "label" Value = Lbl.Caption Case "textbox" Value = TxtB.Text Case "checkbox" Value = FindStrEquivBool(ChkB.Value) Case "optionbutton" 'On va boucler sur tous les option bouttons de la page et repérer les groupenames pour trouver la valeur Case "combobox" 'On boucle sur les lignes If CboB.ListIndex = -1 Then Value = vbNullString Else 'On boucle sur les colonnes Value = ConcatLigne(CboB.List, CboB.ListIndex, NbrColumn:=CboB.ColumnCount - 1) End If Case "listbox" 'On conserve les valeurs contenues sur chaque lignes selectionnées 'On boucle sur les lignes For iList = 0 To LstB.ListCount - 1 'On regarde si l'éléments est selectionné If LstB.Selected(iList) Then 'On prépart le text If Value <> vbNullString Then Value = Value & ";" 'On boucle sur les colonnes Value = Value & ConcatLigne(LstB.List, iList, NbrColumn:=LstB.ColumnCount - 1) End If Next Case Else 'Todo : Traitement End Select End Property Public Property Let Value(aValue As Variant) Dim ListText As String, iList As Integer, iCol As Byte, iTab As Integer, boFind As Boolean Dim tabLigne As Variant, tabCol As Variant, tabConcat As Variant 'On défini le contenu Select Case LCase(TypeName(pGenericControl)) Case "label" Lbl.Caption = CStr(aValue) Case "textbox" TxtB.Text = CStr(aValue) Case "checkbox" 'Prendre en compte les valeur concidérée comme True et False ChkB.Value = ConvertToBoolean(aValue) Case "optionbutton" 'Todo : On va boucler sur tous les option bouttons de la page et repérer les groupenames pour trouver la valeur (à voir) Case "combobox" If aValue <> vbNullString Then 'Préparation du tableau qui contiendra la version concaténée de chaque ligne ReDim tabConcat(0 To CboB.ListCount - 1) As String 'On boucle sur les lignes du listbox For iList = 0 To CboB.ListCount - 1 'On nourri la liste contenant la version concaténée de chaque ligne tabConcat(iList) = ConcatLigne(CboB.List, iList, NbrColumn:=CboB.ColumnCount - 1) Next 'On RAZ la couleur de fond CboB.BackColor = Color_Defaut 'On recherche cette valeur dans le combobox 'On raz boFind = False For iList = 0 To UBound(tabConcat) If aValue = tabConcat(iList) Then CboB.ListIndex = iList boFind = True Exit For End If Next 'On regarde si la chaine a été trouvée et on l'ajoute si elle n'exise pas (option) If (Not boFind) And (aValue <> vbNullString) Then If CBool(Options And opt_AddingInListIfDataValueAbsent) Then 'On l'ajoute 'On sépare le contenu de chaque colonne tabCol = Split(aValue, "|") 'On ajoute un élement CboB.AddItem tabCol(0) 'On ajoute le contenu des autres colonnes For iCol = 1 To UBound(tabCol) CboB.List(CboB.ListCount - 1, iCol) = tabCol(iCol) Next 'On selectionne la ligne CboB.ListIndex = CboB.ListCount - 1 Else 'Todo : Traitement : Elle n'existe pas et elle n'est pas ajoutée End If 'On met en place la coloration si besoin Option If CBool(Options And opt_ColorControlIfDataValueAbsent) Then CboB.BackColor = CstColor_Vio End If End If Else CboB.ListIndex = -1 End If Case "listbox" 'On sépart les différentes lignes contenues dans aValue tabLigne = Split(aValue, ";") 'Préparation du tableau qui contiendra la version concaténée de chaque ligne ReDim tabConcat(0 To LstB.ListCount - 1) As String 'On boucle sur les lignes du listbox For iList = 0 To LstB.ListCount - 1 'On fait un raz de la selection LstB.Selected(iList) = False 'On nourri la liste contenant la version concaténée de chaque ligne tabConcat(iList) = ConcatLigne(LstB.List, iList, NbrColumn:=LstB.ColumnCount - 1) Next 'On RAZ la couleur de fond LstB.BackColor = Color_Defaut If aValue <> vbNullString Then 'On boucle sur le conteu de la base For iTab = 0 To UBound(tabLigne) 'On recherche cette valeur dans le listbox 'On raz boFind = False For iList = 0 To UBound(tabConcat) If tabLigne(iTab) = tabConcat(iList) Then LstB.Selected(iList) = True boFind = True Exit For End If Next 'On regarde si la chaine a été trouvée If (Not boFind) And (aValue <> vbNullString) Then 'On l'ajoute si option 'On met en place la coloration si besoin Option (avant l'ajout car bug perte selection) If CBool(Options And opt_ColorControlIfDataValueAbsent) Then LstB.BackColor = CstColor_Vio End If If CBool(Options And opt_AddingInListIfDataValueAbsent) Then 'On sépare le contenu de chaque colonne tabCol = Split(tabLigne(iTab), "|") 'On ajoute un élement LstB.AddItem tabCol(0) 'On ajoute le contenu des autres colonnes For iCol = 1 To UBound(tabCol) LstB.List(LstB.ListCount - 1, iCol) = tabCol(iCol) Next 'On selectionne la ligne LstB.Selected(LstB.ListCount - 1) = True Else 'Todo : Traitement : Elle n'existe pas et elle n'est pas ajoutée End If End If Next End If Case Else 'Todo : Traitement End Select End Property '################################################# Private Function ConcatLigne(tableau As Variant, iLigne As Integer, Optional Delimiter As String = "|", Optional NbrColumn As Integer) As String Dim iCol As Integer, iNbrCol As Integer iNbrCol = IIf(IsMissing(NbrColumn), UBound(tableau, 2), NbrColumn) For iCol = 0 To iNbrCol 'On place le séparateur si besoin If iCol > 0 Then ConcatLigne = ConcatLigne & "|" 'on ajoute le contenu ConcatLigne = ConcatLigne & tableau(iLigne, iCol) Next End Function Friend Function EquivValue(DataValue As Variant) As Boolean 'On défini le contenu Select Case LCase(TypeName(pGenericControl)) Case "label", "textbox" 'Comparaison de string EquivValue = StrComp(DataValue, Me.Value) = 0 Case "checkbox" 'Comparaison binaire EquivValue = ConvertToBoolean(ChkB.Value) = ConvertToBoolean(DataValue) Case "optionbutton" 'Todo Case "combobox", "listbox" EquivValue = DataValue = Me.Value Case Else 'Todo : Traitement 'Pas de liaison vers un Ctrl EquivValue = True End Select End Function Friend Function FindStrEquivBool(aBoolValue As Boolean) As String Dim Liste As Variant If aBoolValue Then 'On va regarder dans la liste des valeurs "Vraies" Liste = Split(pParent.ConformTrueValues, ";") 'On selectionne le 1er nom de la liste si la liste contient des valeurs 'On boucle sur les valeurs If Not IsEmpty(Liste) Then If IsArray(Liste) Then 'On prend la 1ère valeur If UBound(Liste) <> -1 Then FindStrEquivBool = Liste(0) End If End If Else 'On va regarder dans la liste des valeurs "Vraies" Liste = Split(pParent.ConformFalseValues, ";") 'On selectionne le 1er nom de la liste si la liste contient des valeurs 'On boucle sur les valeurs If Not IsEmpty(Liste) Then If IsArray(Liste) Then 'On prend la 1ère valeur If UBound(Liste) <> -1 Then FindStrEquivBool = Liste(0) End If End If End If 'On vérifie que le résultat ne soit pas vide, sinon on place la valeur boolean en texte If FindStrEquivBool = vbNullString Then FindStrEquivBool = CStr(aBoolValue) End Function Friend Function ConvertToBoolean(aValue As Variant) As Boolean 'Toutes les valeurs non True et non contenues dans la liste des ValeurTrue est concidérées comme False, y compris la valeur Empty ou "" Dim ListTrue As Variant, TrueVal As Variant If VarType(aValue) = vbBoolean Then ConvertToBoolean = CBool(aValue) Else 'On va regarder dans la liste des valeurs "Vraies" ListTrue = Split(pParent.ConformTrueValues, ";") 'On boucle sur les valeurs If Not IsEmpty(ListTrue) Then If IsArray(ListTrue) Then For Each TrueVal In ListTrue ConvertToBoolean = aValue = TrueVal If ConvertToBoolean Then Exit For Next End If End If End If End Function Private Sub ColorationBack() 'On regarde la coloration à adopter 'If ColorEmptyNeeded Then If CBool(Options And opt_ColorControlIfNeededIsEmpty) Then pGenericControl.BackColor = IIf(Parent.IfNeededNotEmpty, Color_Defaut, CstColor_Red) Else 'L'option n'est pas ou plus activée pGenericControl.BackColor = Color_Defaut End If End Sub '################################################# Private Sub CboB_Change() LinkedCtrl_Change End Sub Private Sub ChkB_Change() LinkedCtrl_Change End Sub Private Sub LstB_Click() LinkedCtrl_Change End Sub Private Sub TxtB_Change() LinkedCtrl_Change End Sub Private Sub LinkedCtrl_Change() 'Coloration ColorationBack 'On fait remonter à la structure de départ Parent.Parent.DataModule.LinkedControlChange Me End Sub
Cls_DataFields :représente la collection de champs, addossés chaqu'un à une colonne du TS et un controle situé sur le UserForm
Cls_DataField :représente un champ dont le contenu correspond à la ligne active du TS (Cls_Data.ActiveRowIndex)
Cls_Linker :représente le controle lié à un champ, il peut être un TextBox, un Label, un CheckBox, un ComboBox, un ListBox (Il me reste les radio-boutons à traiter et peut-être d'autre type de contrôle comme les images)
Pour ceux qui le souhaitent un fichier et joint à la discussion
++
Qwaz