Discussion :

[Qwazerty]

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

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_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
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

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
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

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_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.
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