Excel | Tableau Structuré | Base de données | UserForm

**Qwazerty** · 26/12/2019, 18h48

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

**Qwazerty** · 26/12/2019, 18h51

Un exemple d'utilisation (Radio Boutons non fonctionnels)
Nom : VuUF.png
Affichages : 777
Taille : 42,5 Ko

Avec le code du UserForm

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
Option Explicit
Private WithEvents MyData As Cls_Data
 
Private Sub CmdAdd_Click()
    MyData.AddRow ChkBoxActiv.Value
 
End Sub
 
Private Sub CmdAskUnique_Click()
    'On regarde si une colonne a été choisie
    If CB_Choix.ListIndex <> -1 Then
        'On va chercher la liste unique
        CB_TestUnique.List() = MyData.Fields.Field(CB_Choix.Value).ValeursUniques
    End If
End Sub
 
Private Sub CmdDel_Click()
    MyData.DeleteRow TxtDelIndex.Text
End Sub
 
Private Sub CmdNextRow_Click()
    MyData.MoveToNextRow
End Sub
 
Private Sub CmdPreviousRow_Click()
    MyData.MoveToPreviousRow
End Sub
 
Private Sub CmdUpdateData_Click()
    MyData.Fields.UpdateAllData
End Sub
 
Private Sub CmdUpdateCtrl_Click()
    MyData.Fields.UpdateAllControls
End Sub
 
 
Private Sub UserForm_Initialize()
Dim aCol As ListColumn
    'On renseigne les controles
    CmbTypeAcces.AddItem "Badge"
    CmbTypeAcces.AddItem "Smartphone"
    CmbTypeAcces.List(CmbTypeAcces.ListCount - 1, 1) = "Apple"
    CmbTypeAcces.AddItem "Smartphone"
    CmbTypeAcces.List(CmbTypeAcces.ListCount - 1, 1) = "Samsung"
    CmbTypeAcces.AddItem "Clef"
 
    LstBoxSecteur.AddItem "Secteur 1"
    LstBoxSecteur.List(LstBoxSecteur.ListCount - 1, 1) = "Journée"
    LstBoxSecteur.AddItem "Secteur 1"
    LstBoxSecteur.List(LstBoxSecteur.ListCount - 1, 1) = "Nuit"
    LstBoxSecteur.AddItem "Secteur 2"
    LstBoxSecteur.List(LstBoxSecteur.ListCount - 1, 1) = "Journée"
    LstBoxSecteur.AddItem "Secteur 2"
    LstBoxSecteur.List(LstBoxSecteur.ListCount - 1, 1) = "Nuit"
 
 
    Set MyData = New Cls_Data
    'On pointe le tableau de data
    MyData.InitDataStructur Me, F_Data.ListObjects("Tab_Auto")
 
    'On pointe un tableau contenant les liens
    MyData.ListeLinkedCtrl = F_Data.Range("Tab_Link").ListObject.DataBodyRange.Value
 
'En remplacement de la ligne précédente, il est possible de rentrer une par une toutes les informations
'    With MyData.Fields.Field("Nom")
'        Set .LinkedCtrl = UF_Test.TxtNom 'Je remplacerais peut-être le property par une function pour facilité l'écriture
'        .IsNeeded = True
'    End With
'
'    With MyData.Fields.Field("Autorisé")
'        Set .LinkedCtrl = UF_Test.CkBAuto
'        .ConformTrueValues = "Oui;Yes;OK"
'    End With
'
'   ... etc
 
 
    'On pointe le textbox qui recevra l'index en cours
    Set MyData.TxtBox_Index = TxtIndex
 
    'Options
    MyData.Options = opt_AddingInListIfDataValueAbsent + opt_ColorControlIfDataValueAbsent + opt_ColorControlIfNeededIsEmpty + opt_CompareDataToCtrlBeforeUpdate
 
    'On prépart la liste des colonne dans le ComboBox dédié au teste
    'On boucle sur les colonnes
    For Each aCol In MyData.Tab_Data.ListColumns
        'On ajoute le nom de la colonne
        CB_Choix.AddItem aCol.Name
    Next
 
 
End Sub
 
Private Sub UserForm_Terminate()
 
    Set MyData = Nothing
End Sub

La base de donnée et le tableau permettant de faire la liaison entre les TS et les UserForm
Nom : TS et Linker.png
Affichages : 767
Taille : 22,7 Ko

4 options sont disponibles

opt_AddingInListIfDataValueAbsent
Si le contenu de la base de donnée ne correspond pas à une des entrées d'un combobox ou d'un listbox lors de l'activation d'un Row
1. Si True : Les données sont ajoutées dans le contrôle
2. Si False : Le contenu de la base est ignoré, le contrôle n'affiche pas les données présentent dans la base pour le composant en question. Un alerte sera émise au changement de Row Actif si l'option idoïne est active.
opt_ColorControlIfDataValueAbsent
Idem au dessus.
1. Si True : Le fond du contrôle vire au parme pour indiquer l'écart avec la base de donnée.
opt_ColorControlIfNeededIsEmpty
Si le champs est identifié comme obligatoire et que le contrôle lié est vide lors de la mise à jour de la base de donnée
1. Si True : La couleur de fond passe au rouge pâle
opt_CompareDataToCtrlBeforeUpdate
Si un écart est constaté entre le contenu de la base et celui des contrôle (des données non enregistrées donc)
1. Si True : Une alerte est émise pour demander à l'utilisateur s'il souhaite enregistrer les données
2. Si False : Pas d'alerte, les données sont perdues. La gestion doit se faire en amont par l'utilisateur avant le changement de Row Actif.

Si la déclaration de l'instance Cls_data est réalisée avec le mot clef "WithEvents", il est ensuite possible d'ajouter du code pour les événements suivants. (Je n'ai rien testé de ce coté, il y aura peut-être des bugs

)

Nom : ListEvent.png
Affichages : 739
Taille : 15,6 Ko

**Qwazerty** · 26/12/2019, 19h00

Concernant le tableau faisant le lien entre champs et contrôles (celui de droite donc)
Nom : TS et Linker.png
Affichages : 762
Taille : 22,7 Ko

Il n'est pas obligatoire. Il est possible de rentrer les informations

Soit en créant un tableau interne ayant la même structure (2 dimensions : Ligne; Colonne)
Soit en saisissant les données directement dans les instances Field

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
    Set MyData = New Cls_Data
    'On pointe le tableau de data
    MyData.InitDataStructur Me, F_Data.ListObjects("Tab_Auto")
 
   With MyData.Fields.Field("Nom")
        Set .LinkedCtrl = UF_Test.TxtNom 'Je remplacerais peut-être le property par une function pour facilité l'écriture
        .IsNeeded = True
    End With
 
    With MyData.Fields.Field("Autorisé")
        Set .LinkedCtrl = UF_Test.CkBAuto
        .ConformTrueValues = "Oui;Yes;OK"
    End With

++
Qwaz

**Qwazerty** · 07/01/2020, 07h27

Salut

Le projet avance, voila à quoi il ressemble après moultes modifications, il ne fonctionne plus pour l'instant donc je ne mets pas le code

Pièce jointe 528800

++
Qwaz

**Qwazerty** · 22/01/2020, 23h23

Salut

Alors je mets le code car il est fonctionnel mais j'ai encore deux trois truc à lui apporter. Si certains veulent tester pour du debugage

Donc désormais il y a 7 Modules de Classes, 6 Fonctionne en couple et un tout seul.

Cls_OptBoutGroupe

Cls_OptBoutPlus
Ils sont disponible dans la discussion suivante.
Leur fonction est de gérer le controle type OptionBouton et CheckBox lorsqu'il sont utilisés avec la propriété GroupName.

Cls_TSToDataFields

Cls_TSToDataField
Le 1er est la collection et le second les item de celle-ci. Ils créent une couche d'abstraction entre le "Tableau Structuré" (TS par la suite) situé sur une feuille du Classeur et un utilisateur au travers d'un Code VBa qui peut être inclus dans un UserForm.
Ce couple peut-être utilisé seul afin de manipuler le TS comme une table de Base De Données. Cls_TSToDataFields peut-être déclarer avec la clause WithEvents afin d'avoir accès aux différents événements qu'il produit.

Cls_TSToDataLinkers

Cls_TSToDataLinker
Comme pour les couples précédent, il s'agit de la collection et des items associés. Eux aussi créent une couche abstractive mais cette fois entre l'utilisateur et les contrôles situés sur un UserForm.
Ils peuvent être utiliser seul pour gérer les interactions entre l'utilisateur et le UserForm

Cls_TSToDataMaster
Il permet de faire un lien entre les deux couples précédents, tout en nécessitant très très peu de code...
Avec les 4 lignes de code VBA suivantes:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
Private WithEvents MyData As Cls_TSToDataMaster
Private Sub UserForm_Initialize()
    'On initialise le contenu de la zone liste
    CmbTypeAcces.List = F_Data.ListObjects("Tab_TypeAcces").DataBodyRange.Value
 
    'Déclaration de la structure qui gére la base de donnée
    Set MyData = New Cls_TSToDataMaster
    'On pointe le tableau de data
    MyData.InitDataStructur Me, F_Data.ListObjects("Tab_Auto"), True
End Sub

vous pouvez réaliser les opérations suivantes :

Afficher les données contenues dans le TS dans les Contrôles associés du UseForm
Naviguer parmi les enregistrements (ligne) contenus dans le TS
Modifier les données contenues dans le TS
Ajouter et Supprimer des enregistrement (ligne du TS)

Il utilise pour se faire

un DataFields pour gérer l'interaction avec le TS contenant les données à manager.
un DataLinkers permettant de gérer l'affichage des données dans le UserForm
un second DataLinkers permettant de gérer les interactions de l'utilisateur sur le UserForm (Clique bouton, case à coché des options,...)

Comme dans l'exemple fourni plus bas, il peut-être utilisé de façon totalement automatique...
L'utilisateur peut ainsi choisir de laisser le DataMaster faire les actions suivantes

Créer les tableaux de configuration permettant de préciser les liens entre colonne du TS et Contrôles situés sur le Userform. Une fois les tableaux créés, l'utilisateur les renseigne et ils seront prit en compte lors des lancement suivant.
Se charges des 4 opérations cité plus haut (Afficher, Naviguer, Modifier, Ajouter )

Il est bien sûr possible de gérer soit même tout ou partie des interactions, voir de les compléter à l'aide des nombreux événements fourni par le DataMaster.

Voila une vue d'ensemble des interactions entres les différents intervenant
Nom : Archi.png
Affichages : 712
Taille : 108,5 Ko

Nom : Archi.png
Affichages : 712
Taille : 108,5 Ko

Pour ceux qui ne souhaitent pas ouvrir le fichier xlam, les différents modules seront dans le prochain message.

++
Qwaz

**Qwazerty** · 22/01/2020, 23h31

Cls_TSToDataFields

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
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
Option Explicit
Option Compare Text
 
'#################################################
'#          Cls_TSToDataFields v1.0
'#################################################
'#
'#  Code by :   Qwazerty
'#              https://www.developpez.net/forums/u723/qwazerty/
'#
'#  Date    :   31/12/19
'#
'#  Mise en ligne sur DVP
'#  http://.... Note: Mettre à jour
'#
'#################################################
 
'https://www.developpez.net/forums/d1809277/logiciels/microsoft-office/general-vba/definir-propriete-defaut-d-classe-personnalisee-vba/
'#################################################
' Events
'#################################################
Public Event BeforeGeneralUpdate(ByVal ti_NewValues As Variant, ByRef Cancel As Boolean)
Public Event AfterGeneralUpdate(ErrorState As Long)
 
Public Event DataValueUpdate(CallerField As Cls_TSToDataField, IsGlobalUpdate As Boolean, ByVal OldValue As Variant)
 
Public Event BeforeActiveRowChange(ByVal ActualIndex As Long, ByRef FuturIndex As Long, ByRef Cancel As Boolean)
Public Event AfterActiveRowChange(ByVal OldIndex As Long, ByVal NewIndex As Long, ByVal ErrorState As Long)
 
Public Event BeforeRowDeleting(ByVal RowIndex As Long, ByRef Cancel As Boolean)
Public Event AfterRowDeleting(ByVal ErrorState As Long)
 
Public Event BeforeRowAdding(ByRef ActiveNewAddedRow As Boolean, ByRef Cancel As Boolean) 'x
Public Event AfterRowAdding(ByVal RowIndex As Long, ByVal ErrorState As Long)
 
 
Public Event LastRowActivate()
Public Event FirstRowActivate()
 
 
'#################################################
' Variables Privées
'#################################################
 
Private pFieldsCollection As Collection
Private pKeys As Collection
Private pParent As Object
Private pReadOnly As Boolean
Private pTab_Data As ListObject
Private pActiveRowIndex As Long
Private pDeletingRow As Boolean 'Note : Ne semble plus utilisé, intéressant si on ajoute la cause du move (User, Deleting, Adding, ...)
Private pSaveData As Variant
 
Private pFlagGlobalupdate As Boolean
 
 
'#################################################
' Constructeur & Destructure & Init
'#################################################
 
 
Private Sub Class_Initialize()
    Set pFieldsCollection = New Collection
    Set pKeys = New Collection
End Sub
 
Private Sub Class_Terminate()
    Set pFieldsCollection = Nothing
    Set pKeys = Nothing
End Sub
 
Public Function InitFields(aParent As Object, Optional aTabData_LO As ListObject) As Long
Dim ErrorState As Long
    ErrorState = SetParent(aParent)
    If Not IsMissing(aTabData_LO) Then ErrorState = ErrorState Or SetTab_Data(aTabData_LO)
 
    InitFields = ErrorState
End Function
 
Public Function ConfigFieldsAttrubuts(ti_ConfigAtt As Variant) As Long
'Tableau (0 to xRow, y to y+1) 'Ligne0 = Entête : NomChamps | NomAttribut | Valeur(Variant)
'ErrLvl: 8  - tableau fourni invalide
'ErrLvl: 16 - Le tableau contient des valeurs incorrectes
Dim ErrorState As Long
Dim iL As Integer, aField As Cls_TSToDataLinker
 
    If VarType(ti_ConfigAtt) Then
        'On boucle sur les lignes
        For iL = 1 To UBound(ti_ConfigAtt)
            'On pointe le field
            Set aField = Field(ti_ConfigAtt(iL, LBound(ti_ConfigAtt)))
 
            If Not aField Is Nothing Then
                'On modifie son attribut
                SetAttribut ti_ConfigAtt(iL, LBound(ti_ConfigAtt) + 1), ti_ConfigAtt(iL, LBound(ti_ConfigAtt) + 2)
            Else
                ErrorState = 16
            End If
        Next
    Else
        ErrorState = 8
    End If
 
    ConfigFieldsAttrubuts = ErrorState
End Function
 
 
'#################################################
' Propriétés & Functions associées
'#################################################
 
Public Function SetParent(aParent As Object) As Long
'ErrLvl: 1024 - Impossible de changer de parent en cours d'instance
    If Not pParent Is aParent Then
        'On s'assure d'interdire les changement de Parent en cours d'instance
        If pParent Is Nothing Then
            Set pParent = aParent
        Else
            SetParent = 1024
        End If
    End If
End Function
 
Public Function SetTab_Data(aTabData_LO As ListObject) As Long
'ErrLvl: 16384 - Impossible de changer de DataBase en cours d'instance
Dim aCol As ListColumn, newField As Cls_TSToDataField
 
    'On s'assure d'interdire les changements de Base en cours d'instance
    If pTab_Data Is Nothing Then
        Set pTab_Data = aTabData_LO
 
        'On vide la collection
        Clear
        'On crée les Fields associés
        If Not pTab_Data Is Nothing Then
            For Each aCol In pTab_Data.ListColumns
                'On ajoute le field correspondant
                AddNewField aCol
            Next
        End If
    Else
        SetTab_Data = 16384
    End If
 
End Function
 
Public Property Get Tab_Data() As ListObject
    Set Tab_Data = pTab_Data
End Property
 
Public Property Get ActiveRowIndex() As Long
    ActiveRowIndex = pActiveRowIndex
End Property
 
Public Property Get ActiveRow() As ListRow
    If pActiveRowIndex <> -1 Then Set ActiveRow = pTab_Data.ListRows(pActiveRowIndex)
End Property
 
Public Property Get IsFirstRowActif() As Boolean
    IsFirstRowActif = (pActiveRowIndex = 1)
End Property
 
Public Property Get IsLastRowActif() As Boolean
    IsLastRowActif = (pActiveRowIndex = RowCount)
End Property
 
Public Property Get IsGlobalUpdate() As Boolean
    IsGlobalUpdate = pFlagGlobalupdate
End Property
 
Public Property Get ReadOnly() As Boolean
    ReadOnly = pReadOnly
End Property
 
Public Property Let ReadOnly(aValue As Boolean)
    pReadOnly = aValue
End Property
 
Public Property Get Count() As Integer
    Count = pFieldsCollection.Count
End Property
 
Public Property Get RowCount() As Long
    If Not pTab_Data Is Nothing Then RowCount = pTab_Data.ListRows.Count
End Property
 
Public Property Get Field(anIndex As Variant) As Cls_TSToDataField
    '{Attribute Value.VB_UserMemId = 0} ' Todo: A Ajouter au bloc note
    'On transmet le field correspondant
    On Error Resume Next
        Set Field = pFieldsCollection.Item(anIndex)
    On Error GoTo 0
 
    'Todo : Ajouter une erreur ? ou laisser la gestion d'erreur par VBE, OU laisser renvoyer Nothing
End Property
 
Public Property Get Values() As Variant
'tableau NomChamps | Valeur
Dim iField As Integer
Dim TMPTab As Variant
    'On retourne un tableau contenant NomChamps | Valeur
    ReDim TMPTab(0 To Count, 1 To 2)
    TMPTab(0, 1) = "NomChamps"
    TMPTab(0, 2) = "Valeur"
 
    For iField = 1 To Count
        TMPTab(iField, 1) = Field(iField).Name
        TMPTab(iField, 2) = Field(iField).DataValue
    Next
    Values = TMPTab
End Property
 
Public Property Get UniqueValues(anIndex As Variant) As Variant
Dim aField As Cls_TSToDataField
    'On pointe le field
    Set aField = Me.Field(anIndex)
 
    If Not aField Is Nothing Then
        'On va chercher les valeurs uniques du field demandé
        UniqueValues = aField.UniqueValues
    End If
End Property
 
 
'#################################################
' Fonctions Interne
'#################################################
 
 
'Todo Passer SetAttribut en Public??
Private Sub SetAttribut(NomAtt, aValue As Variant)    'Todo : Ajouter gestion d'erreur On error goto ErrGestion
    'On défini le type
    Select Case VarType(aValue)
        Case vbString
            CallByName Me, NomAtt, VbLet, CStr(aValue)
        Case vbBoolean
            CallByName Me, NomAtt, VbLet, CBool(aValue)
        Case vbVariant
            CallByName Me, NomAtt, VbLet, aValue
    End Select
End Sub
 
Private Function AddNewField(aColumn As ListColumn) As Cls_TSToDataField
'Function inacessible de l'extérieur, les fields doivent forcement être attaché à une colonne d'une ListObject
Dim aField As Cls_TSToDataField
 
    'On crée un nouveau champs
    Set aField = New Cls_TSToDataField
 
    'Initialisation des valeurs
    aField.InitField Me, Count + 1, aColumn
 
    'On le place dans la collection
    pFieldsCollection.Add aField, aColumn.Name 'Todo : Ajouter la gestion des retours d'erreur.... '(passer As long ici et ajouter un function LastAddedField)
    'On conserve la correspondance entre key et index
    pKeys.Add aColumn.Name
 
    'On retourne le nouveau Field
    Set AddNewField = Field(aColumn.Name)
End Function
 
Private Function SetActiveRowIndex(NewIndex As Long) As Long
'ErrLvl : 8192  - L'index demandé n'est pas disponible
'ErrLvl : 512   - Demande refusée par l'utilisateur
Dim Cancel As Boolean, FuturIndex As Long, OldIndex As Long
Dim ErrorState As Long
 
    FuturIndex = NewIndex
 
    If (pActiveRowIndex <> FuturIndex) And (Not pTab_Data Is Nothing) Then
        RaiseEvent BeforeActiveRowChange(pActiveRowIndex, FuturIndex, Cancel)
 
        OldIndex = pActiveRowIndex
        If Not Cancel Then
            'On s'assure que l'index visé est dans l'interval dispo
            If ((FuturIndex > 0) And (FuturIndex <= RowCount)) Or FuturIndex = -1 Then
                'On change le pointeur de ligne
                pActiveRowIndex = FuturIndex
                'On retourne les events
                If IsFirstRowActif Then
                    RaiseEvent FirstRowActivate
                ElseIf IsLastRowActif Then
                    RaiseEvent LastRowActivate
                End If
            Else
                ErrorState = 8192
            End If
        Else
            ErrorState = 512
        End If
 
        RaiseEvent AfterActiveRowChange(OldIndex, FuturIndex, ErrorState) 'Note : La demande d'update se fera ici à partir du DataMaster/Utilisateur
    End If
 
    SetActiveRowIndex = ErrorState
End Function
 
 
'#################################################
' Fonctions Externes
'#################################################
 
 
Public Function DataToList(Optional ti_Filtre As Variant)
 
End Function
 
Public Function UpdateDataField(ByVal ti_NewValues As Variant, Optional ClearMissing As Boolean = True) As Long
'ti_NewValues doit contenir le nom des champs en entête
                           'les nouvelles valeurs sur une ligne
'ClearMissing :      Si true, les champs non précisés sont remis à vide
'                   'Si False, les champs conservent leurs anciennes valeurs
 
'ErrLvl: 4      - Aucune valeur testée en attente (logiquement impossible)
'ErrLvl: 8      - tableau fourni invalide
'ErrLvl: 64  - Valeur obligatoire nulle transmises
'ErrLvl: 128 - ReadOnly:Impossible de modifier les valeurs
'ErrLvl: 256 - Pas de Row Actif
'ErrLvl: 512 - Demande refusée par l'utilisateur
Dim aField As Cls_TSToDataField
Dim iField As Integer, IndexFinded As Integer, iRow As Integer
Dim StrTest As String
Dim ErrorState As Long, Cancel As Boolean
 
    'Evenement
    RaiseEvent BeforeGeneralUpdate(ti_NewValues, Cancel)
 
    If Not Cancel Then
        'On vérifie que le tableau est un tableau valide
        If VarType(ti_NewValues) Then
            'On vérifie que les valeurs soient cohérentes (autorisation en écriture, droits,...)
            'On boucle sur les Fields
            iField = 1
            While (iField <= Count) And (ErrorState = 0)
                'On pointe le field correspondant
                Set aField = Field(iField)
                'On boucle sur le tableau
                IndexFinded = -1
                iRow = 1 'LBound(ti_NewValues)
                While (iRow <= UBound(ti_NewValues)) And (IndexFinded = -1)
                    'On regarde si l'entête correspond
                    If aField.Name = ti_NewValues(iRow, LBound(ti_NewValues, 2)) Then IndexFinded = iRow
                    iRow = iRow + 1
                Wend
 
                'On transmet la nouvelle valeurs au Field pour test
                'Si le champs n'a pas de nouvelle valeur prévue, on test sa valeur existante
                StrTest = vbNullString
                If IndexFinded <> -1 Then
                    StrTest = ti_NewValues(IndexFinded, UBound(ti_NewValues, 2))
                Else
                    If Not ClearMissing Then StrTest = aField.DataValue
                End If
 
                ErrorState = ErrorState Or aField.TestUpdateValue(StrTest)
                iField = iField + 1
            Wend
 
            '
            'On vérfie que toutes les valeurs étaient OK et si c'est bon, on valide
            If (ErrorState = 0) Then
                'On crée un point de sauvegarde
                pSaveData = Values
                'On boucle sur les fields
                iField = 1
                While (iField <= Count) And ErrorState = 0
                    ErrorState = Field(iField).UpdateWithLastTestValue
                    iField = iField + 1
                Wend
                'On regarde si la mise à jour c'est arrêtée en cours de route (données compromises)
                If ErrorState <> 0 Then
                    'On annule les modifications de la base
                    While iField > 0
                        If Field(iField).DataValue <> pSaveData(iField, 2) Then Field(iField).Undo
                        iField = iField - 1
                    Wend
                End If
            End If
        Else
            ErrorState = 8
        End If
    Else
        ErrorState = 512
    End If
 
    'On transmet le résultat
    UpdateDataField = ErrorState
 
    'Evenement
    RaiseEvent AfterGeneralUpdate(ErrorState)
 
End Function
 
Public Function Undo()
    'On force la remise en place des data sauvegardée
    'Il faudrait prendre une mesure pour ne pas écraser toutes les valeurs si pSaveData ne contient rien
    'Idem lors d'un changement de contenu d'un field, il faut mettre à jour pSaveData sauf si c'est modifications sont lié à Undo lui même Undoing (accès public)
End Function
 
Public Sub Clear()
Dim iField As Integer
    For iField = Count - 1 To 0 Step -1
        pFieldsCollection.Remove iField
        pKeys.Remove iField
    Next
End Sub
 
Public Function MoveToNextRow() As Long
    MoveToNextRow = MoveToRow(pActiveRowIndex + 1)
End Function
 
Public Function MoveToPreviousRow() As Long
    MoveToPreviousRow = MoveToRow(pActiveRowIndex - 1)
End Function
 
Public Function MoveToFirstRow() As Long
    MoveToFirstRow = MoveToRow(1)
End Function
 
Public Function MoveToLastRow() As Long
    MoveToLastRow = MoveToRow(pTab_Data.ListRows.Count)
End Function
 
Public Function MoveByOffset(OffSet As Long) As Long
    MoveByOffset = MoveToRow(pActiveRowIndex + OffSet)
End Function
 
Public Function MoveToRow(Index As Long) As Long
Dim Cancel As Boolean, GoUpdateData As Boolean
Dim OldIndex As Long, FuturIndex As Long
Dim ErrorState As Long
 
    'On change le pointeur de place
    ErrorState = SetActiveRowIndex(Index)
 
    If ErrorState = 0 Then MoveToRow = pActiveRowIndex
 
End Function
 
Public Function AddRow(Optional ActivateNewAddedRow As Boolean = False) As ListRow
'ErrLvl: 512 - Demande refusée par l'utilisateur
'ErrLvl: 1   - Erreur d'inscription dans la Base (AddRow)
Dim iField As Integer
Dim ActNewRow As Boolean, Cancel As Boolean
Dim ErrorState As Long, IndexNewR As Integer
 
    'On informe l'utilisateur
    ActNewRow = ActivateNewAddedRow
    RaiseEvent BeforeRowAdding(ActNewRow, Cancel)
 
    If Not Cancel Then
        Set AddRow = pTab_Data.ListRows.Add
    Else
        ErrorState = 512
    End If
 
    If AddRow Is Nothing Then
        'On ne pointe une erreur que si l'opération n'a pas été annulée
        If ErrorState = 0 Then ErrorState = 1
        IndexNewR = -1
    Else
        IndexNewR = AddRow.Index
    End If
 
    'On active le nouveau row si necessaire
    If ActNewRow And (ErrorState = 0) Then MoveToRow AddRow.Index
 
    RaiseEvent AfterRowAdding(IndexNewR, ErrorState)
 
End Function
 
Public Function DeleteRow(Optional anIndex As Long) As Long
'ErrLvl : 8192  - L'index demandé n'est pas disponible
'ErrLvl : 32768 - Impossible de changer le RowActif
Dim Cancel As Boolean
Dim ErrorState As Long
Dim DelIndex As Long
 
    'On regarde si un index est précisé, sinon on prend l'index Actif
    DelIndex = IIf(anIndex = 0, pActiveRowIndex, anIndex)
    'On regarde si l'index existe
    If (RowCount >= DelIndex) And (DelIndex > 0) Then
        'On informe l'utilisateur
        RaiseEvent BeforeRowDeleting(DelIndex, Cancel)
        If Not Cancel Then
            'On informe que la destruction de cette ligne est en cours
            pDeletingRow = True
            'On vérifie que l'DelIndex du row actif ne se retrouvera pas en dehors de la plage une fois le row supprimé
            If pActiveRowIndex = RowCount Then
                'On s'assure que le RowActif c'est bien déplacé
                If MoveToPreviousRow <> RowCount Then
                    'On regarde si le row à supprimer est le dernier
                    If RowCount = 1 Then SetActiveRowIndex -1
 
                    'On supprime le Row
                    pTab_Data.ListRows(DelIndex).Delete
                    DeleteRow = True
                Else
                    'Probablement l'utilisateur qui a modifié l'DelIndex de destination via l'Event MoveTo, il a peut-être remis l'DelIndex sur la ligne qui va être éjectée
                    ErrorState = 32768
                End If
            End If
            pDeletingRow = False
        End If
    Else
        ErrorState = 8192
    End If
 
    RaiseEvent AfterRowDeleting(ErrorState)
    DeleteRow = ErrorState
End Function
 
    Public Event TestingUpdateValue(CallerField As Cls_TSToDataField, ByVal Value As String, ByRef RejectValue As Boolean)
 
 
Friend Sub Event_TestingUpdateValue(CallerField As Cls_TSToDataField, ByVal Value As String, ByRef RejectValue As Boolean)
    'On transmet à l'utilisateur
    RaiseEvent TestingUpdateValue(CallerField, Value, RejectValue)
End Sub
 
Friend Sub Event_DataValueUpdate(CallerField As Cls_TSToDataField, IsGlobalUpdate As Boolean, ByVal OldValue As Variant)
    'On transmet à l'utilisateur
    RaiseEvent DataValueUpdate(CallerField, IsGlobalUpdate, OldValue)
End Sub

Cls_TSToDataField

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
Option Explicit
Option Compare Text
 
'#################################################
'#          Cls_TSToDataField v1.0
'#################################################
'#
'#  Code by :   Qwazerty
'#              https://www.developpez.net/forums/u723/qwazerty/
'#
'#  Date    :   31/12/19
'#
'#  Mise en ligne sur DVP
'#  http://.... Note: Mettre à jour
'#
'#################################################
 
 
'#################################################
'Variables Privées
'#################################################
 
Private pParent As Cls_TSToDataFields
Private pLinkedColumn As ListColumn
Private pIndex As Integer
Private pIsNeeded As Boolean
 
Private pMemoValue As String
Private pFlagMemoUp As Boolean
 
Private pSaveValue As Variant
 
'#################################################
' Constructeur & Destructure & Init
'#################################################
 
 
Public Function InitField(aParent As Cls_TSToDataFields, aIndex As Integer, aColumn As ListColumn) As Long
'ErrLvl: 1024 - Impossible de changer de parent en cours d'instance
'ErrLvl: 2048 - Une ListColumn doit obligatoirement être cfigurée
Dim ErrorState As Long
 
    'On enregistre son index
    pIndex = aIndex
    'Ajout de parent
    ErrorState = SetParent(aParent)
    'Ajout de la Colonne
    ErrorState = ErrorState Or SetLinkedColumn(aColumn)
 
    InitField = ErrorState
End Function
 
 
'#################################################
' Property
'#################################################
 
 
Public Property Get Index() As Integer
    Index = pIndex
End Property
 
Private Function SetParent(aParent As Object) As Long
'ErrLvl: 1024 - Impossible de changer de parent en cours d'instance
    If Not pParent Is aParent Then
        'Changement de parent impossible une fois défini
        If pParent Is Nothing Then
            Set pParent = aParent
        Else
            SetParent = 1024
        End If
    End If
End Function
 
Public Property Get Parent() As Cls_TSToDataFields
    Set Parent = pParent
End Property
 
Public Property Get LinkedColumn() As ListColumn
    Set LinkedColumn = pLinkedColumn
End Property
 
Public Function SetLinkedColumn(aColumn As ListColumn) As Long
    'Pas de changement après l'instanciation
    If pLinkedColumn Is Nothing Then
        If Not aColumn Is Nothing Then Set pLinkedColumn = aColumn
    Else
        SetLinkedColumn = 2048
    End If
End Function
 
Public Property Get ActiveRow() As ListRow
    Set ActiveRow = pParent.ActiveRow
End Property
 
Public Property Get Name() As String
    If Not pLinkedColumn Is Nothing Then Name = pLinkedColumn.Name
End Property
 
Public Property Get DataValue() As Variant 'Todo : à remplacer par Value
    'Retourne la valeur contenu dans la base
    If IsReadyToUse Then DataValue = pLinkedColumn.DataBodyRange(ActiveRow.Index).Value       'TransformDelim(pLinkedColumn.DataBodyRange(ActiveRow.Index).Value, tdo_Encode)
End Property
 
Private Property Let DataValue(aValue As Variant)
    'On remplace les délimiteurs pour avoir un affichage plus lisible dans la base
    If IsReadyToUse Then
        'On sauvegarde la valeur actuelle (Undo)
        pSaveValue = pLinkedColumn.DataBodyRange(ActiveRow.Index).Value
        pLinkedColumn.DataBodyRange(ActiveRow.Index).Value = aValue 'TransformDelim(aValue, tdo_Decode)
        pParent.Event_DataValueUpdate Me, pParent.IsGlobalUpdate, pSaveValue
    End If
End Property
 
Public Property Get IsNeeded() As Boolean
    IsNeeded = pIsNeeded
End Property
 
Public Property Let IsNeeded(aValue As Boolean)
    pIsNeeded = aValue
End Property
 
Private Property Get IsReadyToUse() As Boolean
    'On vérifie les deux infos principales (Colonne et Controle)
    IsReadyToUse = Not (pLinkedColumn Is Nothing Or ActiveRow Is Nothing)
End Property
 
Private Property Get ReadOnly() As Boolean
    ReadOnly = pParent.ReadOnly
End Property
 
Private Property Get IsGlobalUpdate()
    IsGlobalUpdate = pParent.IsGlobalUpdate
End Property
 
'#################################################
' Fonctions Externes
'#################################################
 
 
Public Function TestUpdateValue(aValue As String) As Long
'ErrLvl: 64  - Valeur obligatoire nulle transmises
'ErrLvl: 128 - ReadOnly:Impossible de modifier les valeurs
'ErrLvl: 256 - Pas de Row Actif
'ErrLvl: 512 - Demande refusée par l'utilisateur
Dim ErrorState As Long
Dim RejectValue As Boolean
 
    'On regarde si les conditions d'update sont présentes
    'Obligatoire <> ""
    If pIsNeeded And (aValue = vbNullString) Then ErrorState = ErrorState Or 64
    If ReadOnly Then ErrorState = ErrorState Or 128
    If ActiveRow Is Nothing Then ErrorState = ErrorState Or 256
 
    'On transmet un event pour demander des contrôles supplémentaires à l'utilisateur (code retourné "RefuséParUser")
    pParent.Event_TestingUpdateValue Me, aValue, RejectValue
    If RejectValue Then ErrorState = ErrorState Or 512
 
    If ErrorState = 0 Then
        'La valeur est stockée en vu d'une validation ultérieur
        pMemoValue = aValue
        'On monte le flag valeur en attente de validation
        pFlagMemoUp = True
    Else
        pFlagMemoUp = False
    End If
 
    'On retourne la valeur d'erreur
    TestUpdateValue = ErrorState
End Function
 
Public Sub RazMemoValue()
    pMemoValue = vbNullString
    pFlagMemoUp = False
End Sub
 
Public Function UpdateWithLastTestValue() As Long
'ErrLvl : 4 : Aucune valeur en attente
    'On utilise la valeur stockée lors du test
    'On desactive le flag valeur en attente de validation
    'On regarde qu'un valeur soit en attente de mise à jour
    If pFlagMemoUp Then
        'On transmet cette valeur
        UpdateWithLastTestValue = UpdateData(pMemoValue)
        RazMemoValue
    Else
        UpdateWithLastTestValue = 4
    End If
End Function
 
Public Function UpdateData(NewValue As String) As Long
'ErrLvl: 1 - Erreur d'inscription dans la Base
Dim ErrorState As Long
 
    'On vérifie si la valeur avait déjà été testé
    If pMemoValue <> NewValue Then
        'On la teste
        ErrorState = TestUpdateValue(NewValue)
    End If
 
    If ErrorState = 0 Then
        'On modifie la valeur dans la base
        DataValue = NewValue
        'On s'assure que la donnée a bien était inscrite
        If DataValue <> NewValue Then ErrorState = ErrorState Or 1
    End If
 
 
'A refaire
 
'Dim Cancel As Boolean
'    Parent.DataModule.Event_UpdateField Me, True, False, IsGlobalUpdate, Cancel
'    If Not Cancel Then
'    End If
'    Parent.DataModule.Event_UpdateField Me, False, False, IsGlobalUpdate, UpdateDone:=CInt(UpdateCtrl) Or (-CInt(Cancel))
End Function
 
Friend Sub Undo()
    'On rétabli l'ancienne valeur sans faire de contrôle
    If IsReadyToUse Then pLinkedColumn.DataBodyRange(ActiveRow.Index).Value = pSaveValue
End Sub
 
Public Function UniqueValues() As Variant
'Retour une liste contenant toutes les valeurs de la colonne sans doublon
Dim iSource As Long, iDest As Long
Dim tab_Val As Variant
Dim tmpValues As Variant
 
    'Init
    tmpValues = CstDelim3
    '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, tmpValues, CstDelim3 & tab_Val(iSource, 1) & CstDelim3, vbTextCompare) = 0 Then
                'Le mot n'existe pas, on l'ajoute
                tmpValues = tmpValues & tab_Val(iSource, 1) & CstDelim3
            End If
        End If
    Next
 
    'On nettoie le résultat
    'On supprime le 1er caractère de la chaine (CstDelim3)
    tmpValues = Right(tmpValues, Len(tmpValues) - Len(CstDelim3))
    'On supprime le CstDelim3 final
    If tmpValues <> vbNullString Then tmpValues = Left(tmpValues, Len(tmpValues) - Len(CstDelim3))
 
    'On crée le tableau de valeurs
    UniqueValues = Split(tmpValues, CstDelim3)
End Function

Cls_TSToDataLinkers

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
426
Option Explicit
Option Compare Text
 
'#################################################
'#          Cls_TSToDataLinkers v1.0
'#################################################
'#
'#  Code by :   Qwazerty
'#              https://www.developpez.net/forums/u723/qwazerty/
'#
'#  Date    :   31/12/19
'#
'#  Mise en ligne sur DVP
'#  http://.... Note: Mettre à jour
'#
'#################################################
 
'#################################################
' Events
'#################################################
    Public Event BeforeUpdateValues(ByVal it_Values As Variant, ByVal ClearMissing As Boolean, ByRef Cancel As Boolean)
    Public Event AfterUpdateValues(ByVal ErrorState As Long)
 
    Public Event BeforeUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByRef Cancel As Boolean)
    Public Event AfterUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByVal ErrorState As Long)
 
    Public Event NewLinkerAdded(NewLinker As Cls_TSToDataLinker)
    Public Event LinkerChange(CallerLinker As Cls_TSToDataLinker)
    Public Event NeedConvertToBoolean(CallerLinker As Cls_TSToDataLinker, aValue As Variant, ByRef NewValue As Variant)
    Public Event NeedAlias(ByVal aLinker As Cls_TSToDataLinker, ByRef CommaListAlias As String)
    Public Event AddInLinkerList(CallerLinker As Cls_TSToDataLinker, ByVal NewValue As String, ByRef Cancel As Boolean)
    Public Event ValueNotInList(CallerLinker As Cls_TSToDataLinker, ByVal UnknowValue As String)
 
 
'#################################################
' Variables Privées
'#################################################
 
    Private pLinkers_Collection As Collection
    Private pParent As Object
    Private pGlobalUpdate As Boolean
 
 
'#################################################
' Contructuer & Destructeur & Init
'#################################################
 
 
Private Sub Class_Initialize()
    Set pLinkers_Collection = New Collection
End Sub
 
 
Private Sub Class_Terminate()
    Set pLinkers_Collection = Nothing
End Sub
 
Public Function InitLinkers(aParent As Object, Optional ti_Create As Variant) As Long
'ti_Config : Tableau interne de valeurs 2 colonne, x ligne
            'Colonne 1  : Nom de la colonne/Action   (Colonne si controle de visualition/modif - Action si controle de commande Recordset
            'Colonne 2  : Nom du controle à associer
            'Colonne ...: Indifférent
            'Lignes     : Autant que necessaire pour réaliser toutes les liaisons souhaitées
'ErrLvl: 1024 - Impossible de changer de parent en cours d'instance
'ErrLvl: 4096 - Parent non compatible, "Controls" absent
Dim ErrorState As Long
 
    'On traite l'info Parent
    ErrorState = SetParent(aParent)
 
    'On traite le tableau de Configuration
    If Not IsMissing(ti_Create) Then ErrorState = ErrorState Or CreateLinker(ti_Create)
 
    InitLinkers = ErrorState
End Function
 
Public Function CreateLinker(ti_Config As Variant) As Long
'ti_Config contient un tableau de valeurs ayant au moins les deux premières entêtes  suivantes: NomColonne/Action | NomControle |......
'XX ErrLvl: 16 - Le tableau contient des valeurs incorrectes
'ErrLvl: 8  - La structure du tableau fourni invalide ou vide
Dim ErrorState As Long
Dim aCtrl As MSForms.Control, iLigne As Integer, NomCol As String, NomCtrl As String
Dim NewLinker As Cls_TSToDataLinker
 
    'On traite le tableau de Configuration
    If VarType(ti_Config) Then
 
        'on boucle sur le tableau en sautant la 1ère ligne (0 Enetête
        iLigne = IIf(LBound(ti_Config) = 0, 1, LBound(ti_Config))
        While iLigne <= UBound(ti_Config) 'And ErrorState = 0'Si la configuration c'est mal passé, on passe tout de même aux suivant, le control ne sera pas géré
            Set aCtrl = Nothing
            NomCol = vbNullString
            NomCtrl = vbNullString
            'On récupère le nom de la colonne et on pointe le controle
            On Error Resume Next
                NomCol = ti_Config(iLigne, LBound(ti_Config, 2))
                NomCtrl = ti_Config(iLigne, LBound(ti_Config, 2) + 1)
                If NomCtrl <> vbNullString Then Set aCtrl = pParent.Controls(NomCtrl)
            On Error GoTo 0
            'On vérifie
            If (NomCol <> vbNullString) Then
                'On crée un Linker
                Set NewLinker = New Cls_TSToDataLinker
                'On le configure
                ErrorState = ErrorState Or NewLinker.InitLinker(Me, Count + 1, NomCol, aCtrl)
                'On accepte que la structure n'est pas de controle associé
                If ErrorState = 0 Or ErrorState = 32 Then
                    'On ajoute à la collection
                    pLinkers_Collection.Add NewLinker, NomCol
                    'On déclenche un event
                    RaiseEvent NewLinkerAdded(Linker(NomCol))
                    'On vide le pointer
                    Set NewLinker = Nothing
                End If
            Else
                'Contenu incorrect
                ErrorState = 16
            End If
            iLigne = iLigne + 1
        Wend
    Else
        'Contenu incorrect
        ErrorState = 8
    End If
 
End Function
 
Public Function ConfigLinkersAttributs(ti_ConfigAtt As Variant) As Long
'Modfie les Attributs selon le tableau suivant
'Tableau (0 to xRow, y to y+1) 'Ligne0 = Entête : NomChamps | NomAttribut | Valeur(Variant)
'ErrLvl: 8  - tableau fourni invalide
'ErrLvl: 16 - Le tableau contient des valeurs incorrectes
Dim ErrorState As Long
Dim iL As Integer, aLinker As Cls_TSToDataLinker
 
    If VarType(ti_ConfigAtt) Then
        'On boucle sur les lignes
        For iL = 1 To UBound(ti_ConfigAtt)
            'On pointe le field
            Set aLinker = Linker(ti_ConfigAtt(iL, LBound(ti_ConfigAtt)))
 
            If Not aLinker Is Nothing Then
                'On modifie son attribut
                SetAttribut ti_ConfigAtt(iL, LBound(ti_ConfigAtt) + 1), ti_ConfigAtt(iL, LBound(ti_ConfigAtt) + 2)
            Else
                ErrorState = 16
            End If
        Next
    Else
        ErrorState = 8
    End If
 
    ConfigLinkersAttributs = ErrorState
End Function
 
'#################################################
' Propriétés
'#################################################
 
Public Function SetParent(aParent As Object) As Long
'ErrLvl: 1024 - Impossible de changer de parent en cours d'instance
'ErrLvl: 4096 - Parent non compatible, "Controls" absent
Dim aControlsOption As Controls
Dim ErrorState As Long
 
    If Not pParent Is aParent Then
        'On autorise pas le changement de parent en cours d'instance
        If (pParent Is Nothing) Then
            'On s'assure que le parent à une propriété Controls
            On Error Resume Next
                Set aControlsOption = aParent.Controls
            On Error GoTo 0
            If (Not aControlsOption Is Nothing) Then
                Set pParent = aParent
            Else
                ErrorState = 4096
            End If
        Else
            ErrorState = 1024
        End If
    End If
 
    SetParent = ErrorState
End Function
 
Public Property Get Parent() As Object
    Parent = pParent
End Property
 
Public Function SetReadOnly(aValue As Boolean)
Dim iLk As Integer
    'On boucle sur les Linker
    For iLk = 1 To Count
        Linker(iLk).Locked = aValue
    Next
End Function
 
Public Function SetEnabled(aValue As Boolean)
Dim iLk As Integer
    'On boucle sur les Linker
    For iLk = 1 To Count
        Linker(iLk).Enabled = aValue
    Next
End Function
 
Public Property Get Count() As Integer
    Count = pLinkers_Collection.Count
End Property
 
Public Property Get Linker(Index As Variant) As Cls_TSToDataLinker
    '{Attribute Value.VB_UserMemId = 0} ' Todo: A Ajouter au bloc note
    'On recherche si le nom correspond au nom de la cellule
    On Error Resume Next
        Set Linker = pLinkers_Collection(Index)
    On Error GoTo 0
 
    'Todo : Ajouter un erreur Event ?
 
End Property
 
Public Property Get LinkerByCtrl(CtrlName As String) As Cls_TSToDataLinker
Dim iLinker As Integer
    iLinker = 1
    'On boucle
    Do While (iLinker <= Count) And (LinkerByCtrl Is Nothing)
        If Linker(iLinker).IsLinked Then
            If Linker(iLinker).LinkedControl.Name = CtrlName Then
                LinkerByCtrl = Linker(iLinker)
            End If
        End If
        iLinker = iLinker + 1
    Loop
 
End Property
 
Public Function GetValues(Optional WithVirtual As Boolean) As Variant
'WithVirtual = Y compris les linkers n'ayant pas de controle lié (défaut False)
Dim iLinker As Integer
Dim TMPTab As Variant, iTab As Integer
 
 
'Todo : Modifier pour prendre en compte WithVitual
'Il faut dimensionner le tableau au plus juste
 
    'Retour un tableau contenant le couple NomChamps | Valeur
    If WithVirtual Then
        ReDim TMPTab(1 To 2, 0 To Count)
    Else
        ReDim TMPTab(1 To 2, 0 To 5)
    End If
 
    'On place les entêtes sur la ligne 0
    TMPTab(1, 0) = "NomChamps"
    TMPTab(2, 0) = "Valeur"
 
    'On rempli les couples
    iTab = 1
    For iLinker = 1 To Count
        'On transmet les valeurs des champs lié à un controle sur le userForm
        If Linker(iLinker).IsLinked Or WithVirtual Then
            'On regarde si la dimension du tableau est cohérente
            If iTab > UBound(TMPTab, 2) Then ReDim Preserve TMPTab(1 To 2, 0 To iTab + 4)
            TMPTab(1, iTab) = Linker(iLinker).Name
            TMPTab(2, iTab) = Linker(iLinker).Value
            iTab = iTab + 1
        End If
    Next
 
    'On supprime les lignes non utilisées
    ReDim Preserve TMPTab(1 To 2, 0 To iTab - 1)
 
    'On transpose pour réorganiser ligne, colonne
    GetValues = Transpose_ti(TMPTab)
End Function
 
Public Function SetValues(it_Values As Variant, Optional ClearMissing As Boolean = True) As Long
'Tableau contenant les couples NomChamps/Valeur à partir de la 1ère ligne 1ère colonne (Base 1)
'ErrLvl : 512   - Demande refusée par l'utilisateur
 
Dim iLinker As Integer, iTab As Integer
Dim Cancel As Boolean, ErrorState As Long
Dim FindCtrl As Boolean
 
    RaiseEvent BeforeUpdateValues(it_Values, ClearMissing, Cancel)
 
    If Not Cancel Then
        'On flag la mise à jour global
        pGlobalUpdate = True
 
        'Transfert les valeurs à afficher en fonction du contenu du tableau NomChamps | Valeur
        iLinker = 1
        While iLinker <= Count
            'On cherche le linker dans le tableau
            With Linker(iLinker)
                FindCtrl = False
                For iTab = 1 To UBound(it_Values)
                    If it_Values(iTab, 1) = .Name Then
                        .Value = it_Values(iTab, 2)
                        FindCtrl = True
                        Exit For
                    End If
                Next
                'Si option, on remet à zéro les champs non présents dans le tableau (Vrai par defaut)
                If ClearMissing And Not FindCtrl Then .Value = ""
            End With
            iLinker = iLinker + 1
        Wend
 
        'On flag la mise à jour global
        pGlobalUpdate = False
    Else
        ErrorState = 512
    End If
 
    SetValues = ErrorState
    RaiseEvent AfterUpdateValues(ErrorState)
End Function
 
Friend Property Get IsGlobalUpdate() As Boolean
    IsGlobalUpdate = pGlobalUpdate
End Property
 
Public Property Get IsUnkownValues() As Boolean
Dim iLinker As Integer
    iLinker = 1
    While iLinker <= Count And Not IsUnkownValues
        IsUnkownValues = Linker(iLinker).IsUnknowValue
        iLinker = iLinker + 1
    Wend
End Property
 
 
'#################################################
'Procédures Internes
'#################################################
 
 
Private Sub SetAttribut(NomAtt, aValue As Variant)
'Todo : mettre une gestion ErrorState
    'On défini le type
    Select Case VarType(aValue)
        Case vbString
            CallByName Me, NomAtt, VbLet, CStr(aValue)
        Case vbBoolean
            CallByName Me, NomAtt, VbLet, CBool(aValue)
        Case vbVariant
            CallByName Me, NomAtt, VbLet, aValue
    End Select
End Sub
 
 
'#################################################
'Procédures Externes
'#################################################
 
Public Sub Clear()
Dim iLinker As Integer
    For iLinker = Count To 1 Step -1
        pLinkers_Collection.Remove iLinker
    Next
End Sub
 
Public Sub ClearContents()
Dim iLinker As Integer
    For iLinker = Count To 1 Step -1
        Linker(iLinker).Value = ""
    Next
End Sub
 
 
'#################################################
' Gestion Events
'#################################################
 
 
Friend Function Event_NeedConvertToBoolean(aValue As Variant, CallerLinker As Cls_TSToDataLinker) As Boolean
Dim RetourUser As Variant
    RaiseEvent NeedConvertToBoolean(CallerLinker, aValue, RetourUser)
    'On retourne la valeur
    Event_NeedConvertToBoolean = RetourUser
End Function
 
Friend Function Event_NeedAlias(aLinker As Cls_TSToDataLinker) As Variant
'ErrLvl: 2 : La liste fourni n'est pas compatible (vérifier séparateur ;)
'Attent une liste de valeur séparée par ;
Dim ti_retour As Variant, CommaList As String
 
    'On transmet un event à l'utilisateur le nom du champs
    RaiseEvent NeedAlias(aLinker, CommaList)
 
    'On regarde si un retour est fait
    If CommaList <> vbNullString Then
        'On regarde si le tableau obtenu est compatible
        ti_retour = Split(CommaList, CstDelim1)
        If VarType(ti_retour) Then
            Event_NeedAlias = ti_retour
        Else
            Event_NeedAlias = 2
        End If
    Else
        'Pas d'Alias souhaité
 
    End If
    'Si le tableau n'est pas fourni, on retourne une chaine vide
    If IsEmpty(ti_retour) Then ti_retour = vbNullString
End Function
 
Friend Function Event_LinkedCtrlChange(CallerLinker As Cls_TSToDataLinker)
    RaiseEvent LinkerChange(CallerLinker)
End Function
 
Friend Function Event_AddInLinkerList(CallerLinker As Cls_TSToDataLinker, ByVal NewValue As String, ByRef Cancel As Boolean)
    RaiseEvent AddInLinkerList(CallerLinker, NewValue, Cancel)
End Function
 
Friend Function Event_ValueNotInList(CallerLinker As Cls_TSToDataLinker, ByVal UnknowValue As String)
    RaiseEvent ValueNotInList(CallerLinker, UnknowValue)
End Function
 
Friend Function Event_BeforeUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByRef Cancel As Boolean)
    RaiseEvent BeforeUpdateValue(CallerLinker, UpdateGlobal, Cancel)
End Function
 
Friend Function Event_AfterUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByVal ErrorState As Long)
    RaiseEvent AfterUpdateValue(CallerLinker, UpdateGlobal, ErrorState)
End Function

Cls_TSToDataLinker

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
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
Option Explicit
Option Compare Text
'#################################################
'#          Cls_TSToDataLinker v1.0
'#################################################
'#
'#  Code by :   Qwazerty
'#              https://www.developpez.net/forums/u723/qwazerty/
'#
'#  Date    :   31/12/19
'#
'#  Mise en ligne sur DVP
'#  http://.... Note: Mettre à jour
'#
'#################################################
 
 
 
'#################################################
' Variables Privées
'#################################################
    Private WithEvents Lbl As MSForms.Label
    Private pGenericControl As Object 'MSForms.Control
    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 CmdB As MSForms.CommandButton
    Private WithEvents OptB As Cls_OptBoutGroupe 'Capsule contenant un groupe d'option-boutons
 
    Private pParent As Cls_TSToDataLinkers
    Private pListAlias As String
    Private pIndex As Integer
    Private pName As String
    Private pWithOutEvent As Boolean
    Private pUnknowValue As Boolean
    Private pValueWithoutCtrl As Variant
 
'#################################################
' Constructeur & Destructure & Init
'#################################################
 
Private Sub Class_Initialize()
    Set OptB = New Cls_OptBoutGroupe
End Sub
 
Private Sub Class_Terminate()
    Set OptB = Nothing
End Sub
 
Public Function InitLinker(ByVal aParent As Cls_TSToDataLinkers, ByVal aIndex As Integer, ByVal aName As String, ByVal LinkedCtrl As MSForms.Control) As Long
Dim ErrorState As Long
    pIndex = aIndex
    pName = aName
    ErrorState = SetParent(aParent)
    ErrorState = ErrorState Or SetLinkedControl(LinkedCtrl)
    InitLinker = ErrorState
End Function
 
'#################################################
' Propriétés & Fonctions associées
'#################################################
 
Public Property Get TypeCtrl() As String
    TypeCtrl = TypeName(pGenericControl)
    If TypeCtrl = "Cls_OptBoutGroupe" Then TypeCtrl = OptB.TypeName
End Property
 
Friend Function SetParent(aParent As Cls_TSToDataLinkers) As Long
'ErrLvl: 1024 - Impossible de changer de parent en cours d'instance
 
    If Not pParent Is aParent Then
        'On s'assure d'interdire le changement de Parent en cours d'instance
        If pParent Is Nothing Then
            Set pParent = aParent
        Else
            SetParent = 1024
        End If
    End If
 
End Function
 
Public Property Get Parent() As Cls_TSToDataLinkers
    Set Parent = pParent
End Property
 
Public Property Get Name() As String
    Name = pName
End Property
 
Public Property Get Index() As Integer
    Index = pIndex
End Property
 
Public Property Get IsLinked() As Boolean
'Retourne si le linker à un controle d'attribué
    IsLinked = Not pGenericControl Is Nothing
End Property
 
Public Property Get IsUnknowValue() As Boolean
    IsUnknowValue = pUnknowValue
End Property
 
Public Function SetLinkedControl(aControl As MSForms.Control) As Long
'ErrLvl: 2  : La liste fourni n'est pas compatible (vérifier séparateur ;)
'ErrLvl: 32 : Le control fournis n'est pas compatible
Dim ti_Alias As Variant
Dim CtrlType As String
Dim ErrorState As Long
    'On mémorise le controle
    Set pGenericControl = aControl
 
    'On extrait le type du controle
    CtrlType = LCase(TypeName(pGenericControl))
 
    'On vérifie si c'est un CheckBox s'il à une valeur renseignée dans le GRoupe Name
    If CtrlType = "checkbox" Then
        If pGenericControl.GroupName <> vbNullString Then CtrlType = "GrpCheckBox"
    End If
 
    'On transtype control
    Select Case CtrlType
        Case "label"
            Set Lbl = pGenericControl
        Case "textbox"
            Set TxtB = pGenericControl
        Case "checkbox"
            Set ChkB = pGenericControl
        Case "optionbutton", "GrpCheckBox"
            'On demande à l'utilisateur s'il souhaite fournir un tableau d'alias à destination du groupe de bouton
            ti_Alias = pParent.Event_NeedAlias(Me)
            Select Case VarType(ti_Alias)
                Case vbArray + vbVariant, vbString, vbArray + vbString 'tableau ou Chaine vide
                    OptB.InitializeGroupe pGenericControl, ti_Alias
                Case Else
                    ErrorState = ErrorState Or 2
            End Select
            'On pointe OptB comme étant le controle Generique
            Set pGenericControl = OptB
        Case "combobox"
            Set CboB = pGenericControl
        Case "listbox"
            Set LstB = pGenericControl
        Case "commandbutton"
            Set CmdB = pGenericControl
        Case "nothing"
            'Pas de controle lié
        Case Else
            'Le type de contrôle fourni n'est pas compatible
            Set pGenericControl = Nothing
    End Select
 
    'On mémorise la couleur par défaut
    If pGenericControl Is Nothing Then ErrorState = ErrorState Or 32
 
    SetLinkedControl = ErrorState
End Function
 
Public Property Get LinkedControl() As MSForms.Control
    Set LinkedControl = pGenericControl
End Property
 
Public Property Let BackColor(NewColor As OLE_COLOR)
Dim iList As Integer, Sel() As Boolean
 
'Note: voir pour ajouter un event?
    'On défni la couleur de fond
    'On regarde le type de controle
    Select Case LCase(TypeCtrl)
        Case "listbox"
            'Bug : Le listbox bug lorsqu'on change sa couleur de fond, il perd les items selectionnés....
            'On mémorise les selections
            ReDim Sel(0 To LstB.ListCount - 1)
            For iList = 0 To LstB.ListCount - 1
                Sel(iList) = LstB.Selected(iList)
            Next
            'On applique la coloration
            LstB.BackColor = NewColor
            'On remet en place la selection (sans déclencher d'événement)
            pWithOutEvent = True
            For iList = 0 To LstB.ListCount - 1
                LstB.Selected(iList) = Sel(iList)
            Next
            pWithOutEvent = False
 
        Case "nothing"
 
        Case Else
            pGenericControl.BackColor = NewColor
    End Select
 
End Property
 
Public Property Get BackColor() As OLE_COLOR
    BackColor = pGenericControl.BackColor
End Property
 
Public Property Let Locked(aValue As Boolean)
    On Error Resume Next
        pGenericControl.Locked = aValue
    On Error GoTo 0
End Property
 
Public Property Get Locked() As Boolean
    On Error Resume Next
        Locked = pGenericControl.Locked
    On Error GoTo 0
End Property
 
Public Property Let Enabled(aValue As Boolean)
    On Error Resume Next
        pGenericControl.Enabled = aValue
    On Error GoTo 0
End Property
 
Public Property Get Enabled() As Boolean
    On Error Resume Next
        Locked = pGenericControl.Enabled
    On Error GoTo 0
End Property
 
Public Property Get Value() As Variant
Dim iList As Integer, iCol As Byte
Dim vAlias As Variant
    'On retourne le contenu
    Select Case LCase(TypeCtrl)
        Case "label", "commandbutton"
            Value = pGenericControl.Caption
        Case "textbox"
            Value = TxtB.Text
        Case "grpcheckbox", "checkbox"
            vAlias = pParent.Event_NeedAlias(Me)
            'On controle le retour
            If IsArray(vAlias) Then
                'On retourne la 1ère valeur
                Value = vAlias(0)
            Else
                'En cas d'erreur ou de retour vide, on transmet la valeur brute
                Value = ChkB.Value
            End If
        Case "grpoptionbutton"
            Value = OptB.ActiveAlias
        Case "combobox"
            'On regarde si une selection est en cours
            If CboB.ListIndex <> -1 Then
                'On boucle sur les colonnes
                Value = ConcatLigne(CboB.List, CboB.ListIndex, NbrColumn:=CboB.ColumnCount - 1)
            Else
                'On retourne le texte inscrit 'Note: A tester, tentative pour gérer le combobox en drop mode Combo
                Value = CboB.Text
            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 & CstDelim1
                    'On boucle sur les colonnes
                    Value = Value & ConcatLigne(LstB.List, iList, NbrColumn:=LstB.ColumnCount - 1)
                End If
            Next
        Case "nothing"
            'On retourne la valeur conservée
            Value = pValueWithoutCtrl
    End Select
 
End Property
 
Public Property Let Value(aValue As Variant)
'ErrLvl : 512   - Demande refusée par l'utilisateur
'ErrLvl : 65536 - Valeur demandée non présente dans la liste (ComboBox ou ListBox)
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
Dim Lb As Boolean, StyleDD As Boolean
Dim Cancel As Boolean, AddInList As Boolean, AtLeastOneMiss As Boolean
Dim ReturnValues As Variant, FindV As Boolean
Dim ForceListRet As Variant, ForceListVal As Variant
Dim ErrorState
Dim tiTmp As Variant
 
    'On gère l'event
    pParent.Event_BeforeUpdateValue Me, pParent.IsGlobalUpdate, Cancel
 
    If Not Cancel Then
        'On défini le contenu
        Select Case LCase(TypeCtrl)
            Case "label"
                Lbl.Caption = CStr(aValue)
            Case "commandbutton"
                CmdB.Caption = CStr(aValue)
            Case "textbox"
                TxtB.Text = CStr(aValue)
            Case "grpcheckbox"
                'On regarde si la valeur peut-être convertie en boolean
                If VarType(aValue) = vbBoolean Then
                    'On applique direct
                    ChkB.Value = aValue
                Else
                    'On demande si cette valeur doit être considérée vrai
                    'Si pas de réponse c'est intérpreté comme False
                    ChkB.Value = pParent.Event_NeedConvertToBoolean(aValue, Me)
                End If
            Case "grpoptionbutton"
                'On active le bouton radio correspondant
                ReturnValues = OptB.CheckOptions(aValue)
                'On regarde si tous les boutons ont été trouvés
                ForceListVal = Split(aValue, CstDelim1)
                ForceListRet = Split(ReturnValues, CstDelim1)
 
                iList = LBound(ForceListVal)
                While iList <= UBound(ForceListVal)
                    'On recherche dans le tableau de retour
                    iTab = LBound(ForceListRet)
                    FindV = False
                    While iTab <= UBound(ForceListRet) And Not FindV
                        'On compare les valeurs
                        If ForceListVal(iList) = ForceListRet(iTab) Then FindV = True
                        iTab = iTab + 1
                    Wend
                    If Not FindV Then
                        AtLeastOneMiss = True
                        pParent.Event_ValueNotInList Me, ForceListVal(iList)
                    End If
                    iList = iList + 1
                Wend
            Case "combobox", "listbox"
 
                'On regarde si le controle est un listbox ou un combobox
                Lb = LCase(TypeCtrl) = "listbox"
 
                'On fait un raz de la selection
                If Lb Then
                    For iList = 0 To pGenericControl.ListCount - 1
                        LstB.Selected(iList) = False
                    Next
                Else
                    CboB.ListIndex = -1
                End If
 
                If (aValue <> vbNullString) Then
                    'On sépart les différentes lignes contenues dans aValue
                    tabLigne = Split(aValue, CstDelim1) 'Contenu de la base
 
                    If (pGenericControl.ListCount > 0) Then
                        ReDim tabConcat(0 To pGenericControl.ListCount - 1) As String
                        'On boucle sur les lignes du listbox
                        For iList = 0 To pGenericControl.ListCount - 1
                            'On nourri la liste contenant la version concaténée de chaque ligne
                            tabConcat(iList) = ConcatLigne(pGenericControl.List, iList, NbrColumn:=pGenericControl.ColumnCount - 1)
                        Next
                    End If
 
                    'On boucle sur le contenu de la base
                    For iTab = 0 To UBound(tabLigne)
                        If (pGenericControl.ListCount > 0) Then
                            'On recherche la valeur dans la list de controle
                            boFind = False
                            iList = 0
                            While iList <= UBound(tabConcat) And Not boFind
                                If tabLigne(iTab) = tabConcat(iList) Then
                                    If Lb Then LstB.Selected(iList) = True Else CboB.ListIndex = iList
                                    boFind = True
                                End If
                                iList = iList + 1
                            Wend
                        End If
 
                        'On regarde si la chaine a été trouvée et on l'ajoute si elle n'exise pas (option)
                        If Not boFind Then
                            On Error Resume Next
                                StyleDD = CboB.Style = fmStyleDropDownList
                            On Error GoTo 0
                            AddInList = False
                            If (Lb Or StyleDD) And (pGenericControl.RowSource = "") Then
                                'On passe l'info à l'utilisateur et on demande son avis sur la suite à donner (gestion option)
                                Cancel = False
                                pParent.Event_AddInLinkerList Me, tabLigne(iTab), Cancel
                                If Not Cancel Then
                                    'On l'ajoute
                                    'On sépare le contenu de chaque colonne
                                    tabCol = Split(tabLigne(iTab), CstDelim2) 'Contenu de la base
                                    'On ajoute un élement
                                    LstB.AddItem
                                    pGenericControl.AddItem tabCol(0)
                                    'On ajoute le contenu des autres colonnes
                                    For iCol = 1 To UBound(tabCol)
                                        pGenericControl.List(pGenericControl.ListCount - 1, iCol) = tabCol(iCol)
                                    Next
                                    'On selectionne la ligne
                                    If Lb Then LstB.Selected(LstB.ListCount - 1) = True Else CboB.ListIndex = CboB.ListCount - 1
                                    AddInList = True
                                End If
                            ElseIf Not Lb Then
                                'On place la valeur dans le text 'Note : A tester la gestion du style de combo
                                tiTmp = Split(aValue, "|")
                                CboB.Text = tiTmp(0)
                            End If
                            'On signal à l'utilisateur que l'entrée n'existe pas
                            If Not AddInList Then
                                pParent.Event_ValueNotInList Me, tabLigne(iTab)
                                AtLeastOneMiss = True
                            End If
                        End If
                    Next
                End If
            Case "nothing"
                'On conserve la valeur
                pValueWithoutCtrl = Value
        End Select
 
        'On conserve si oui ou non toutes les valeurs sont présentes
        pUnknowValue = AtLeastOneMiss
        If AtLeastOneMiss Then ErrorState = ErrorState Or 65536
    Else
        ErrorState = ErrorState Or 512
    End If
 
    'On gère l'event
    pParent.Event_AfterUpdateValue Me, pParent.IsGlobalUpdate, ErrorState
End Property
 
 
'#################################################
' Fonction Internes
'#################################################
 
 
Private Function ConcatLigne(ByVal tableau As Variant, ByVal iLigne As Long, Optional Delimiter As String = CstDelim2, 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 & Delimiter
        'on ajoute le contenu
        ConcatLigne = ConcatLigne & tableau(iLigne, iCol)
    Next
End Function
 
 
'#################################################
' Gestion des Events
'#################################################
 
 
Private Sub CboB_Change()
    Event_LinkedCtrl_Change
End Sub
 
Private Sub ChkB_Change()
    Event_LinkedCtrl_Change
End Sub
 
Private Sub CmdB_Click()
    Event_LinkedCtrl_Change
End Sub
 
Private Sub LstB_Change()
    If Not pWithOutEvent Then Event_LinkedCtrl_Change
End Sub
 
Private Sub OptB_OptionChanged(TheOption As Cls_OptBoutPlus)
    Event_LinkedCtrl_Change
End Sub
 
Private Sub TxtB_Change()
    Event_LinkedCtrl_Change
End Sub
 
Private Sub Event_LinkedCtrl_Change()
    'On fait remonter à la structure Parent
    pParent.Event_LinkedCtrlChange Me
End Sub

Code du DataMaster à Suivre (message trop long sinon :s)

++
Qwaz

**Qwazerty** · 22/01/2020, 23h31

Cls_TSToDataMaster

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Excel | Tableau Structuré | Base de données | UserForm

Contribuez