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

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

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, 19h51

Un exemple d'utilisation (Radio Boutons non fonctionnels)
Nom : VuUF.png
Affichages : 1341
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 : 1292
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 : 1278
Taille : 15,6 Ko

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

Concernant le tableau faisant le lien entre champs et contrôles (celui de droite donc)
Nom : TS et Linker.png
Affichages : 1312
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, 08h27

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** · 23/01/2020, 00h23

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 : 1264
Taille : 108,5 Ko

Nom : Archi.png
Affichages : 1264
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** · 23/01/2020, 00h31

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** · 23/01/2020, 00h31

Cls_TSToDataMaster

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
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
Option Explicit
Option Compare Text
 
'#################################################
'#          Cls_TSToDataMaster 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://cafeine.developpez.com/access/tutoriel/regexp/
'https://regex101.com/
 
 
'#################################################
' Events
'#################################################
 
'Constructeur
Public Event Initialize()
Public Event Terminate()
 
Public Event FieldTestingUpdateValue(CallerField As Cls_TSToDataField, ByVal Value As String, ByRef RejectValue As Boolean)
Public Event FieldValueUpdate(CallerField As Cls_TSToDataField, IsGlobalUpdate As Boolean, ByVal OldValue As Variant)
Public Event FieldsAfterGeneralUpdate(ErrorState As Long)
Public Event FieldsBeforeGeneralUpdate(ByVal ti_NewValues As Variant, Cancel As Boolean)
Public Event FieldAfterActiveRowChange(ByVal OldIndex As Long, ByVal NewIndex As Long, ByVal ErrorState As Long)
Public Event FieldAfterRowAdding(ByVal RowIndex As Long, ByVal ErrorState As Long)
Public Event FieldAfterRowDeleting(ByVal ErrorState As Long)
Public Event FieldBeforeActiveRowChange(ByVal ActualIndex As Long, FuturIndex As Long, Cancel As Boolean)
Public Event FieldBeforeRowAdding(ActiveNewAddedRow As Boolean, Cancel As Boolean)
Public Event FieldBeforeRowDeleting(ByVal RowIndex As Long, Cancel As Boolean)
Public Event FieldFirstRowActivate()
Public Event FieldLastRowActivate()
 
Public Event CtrlNeedAlias(ByVal CallerLinker As Cls_TSToDataLinker, ByRef CommaListAlias As String)
Public Event CtrlNeedConvertToBoolean(CallerLinker As Cls_TSToDataLinker, aValue As Variant, NewValue As Variant)
Public Event CtrlAddInLinkerList(CallerLinker As Cls_TSToDataLinker, ByVal NewValue As String, Cancel As Boolean)
Public Event CtrlValueNotInList(CallerLinker As Cls_TSToDataLinker, ByVal UnknowValue As String)
Public Event CtrlAfterUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByVal ErrorState As Long)
Public Event CtrlBeforeUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, Cancel As Boolean)
Public Event CtrlAfterUpdateValues(ByVal ErrorState As Long)
Public Event CtrlBeforeUpdateValues(ByVal it_Values As Variant, ByVal ClearMissing As Boolean, Cancel As Boolean)
Public Event CtrlBeforeRefreshColorBack(TheLinker As Cls_TSToDataLinker, ByRef NewColor As OLE_COLOR, ByRef Cancel)
Public Event CtrlAfterRefreshColorBack(CallerLinker As Cls_TSToDataLinker, ByVal Cancel As Boolean)
Public Event CtrlNewLinkerAdded(NewLinker As Cls_TSToDataLinker)
 
Public Event ActionNewLinkerAdded(NewLinker As Cls_TSToDataLinker)
Public Event ActionNeedAlias(ByVal CallerLinker As Cls_TSToDataLinker, ByRef CommaListAlias As String)
Public Event ActionNeedConvertToBoolean(CallerLinker As Cls_TSToDataLinker, ByVal aValue As Variant, ByRef NewValue As Variant)
Public Event ActionAddInLinkerList(CallerLinker As Cls_TSToDataLinker, ByVal NewValue As String, Cancel As Boolean)
Public Event ActionValueNotInList(CallerLinker As Cls_TSToDataLinker, ByVal UnknowValue As String)
Public Event ActionAfterUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByVal ErrorState As Long)
Public Event ActionBeforeUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, Cancel As Boolean)
Public Event ActionAfterUpdateValues(ByVal ErrorState As Long)
Public Event ActionBeforeUpdateValues(ByVal it_Values As Variant, ByVal ClearMissing As Boolean, Cancel As Boolean)
Public Event ActionManagingEvent(CallerLinker As Cls_TSToDataLinker, ActionName As String)
 
 
'Event LinkerCfgChange(TheLinker As Cls_TSToDataLinker)
 
 
'#################################################
'Variables Privées
'#################################################
 
 
'Private WithEvents Ws_Data As Worksheet
Private WithEvents pDataActions As Cls_TSToDataLinkers
Private WithEvents pDataCtrls As Cls_TSToDataLinkers
Private WithEvents pDataFields As Cls_TSToDataFields
 
Private pParent As UserForm
Private pTab_Data As ListObject
Private pLinkerListMiss As Boolean
 
Private pTab_Ctrls As ListObject
Private pTab_Actions As ListObject
'Données parsées
Private pti_TabCtrls As Variant
Private pti_TabActions As Variant
 
Private DefaultBackColor() As OLE_COLOR
 
 
'#################################################
' Enumérations & Constante
'#################################################
 
'Options
Private pOptions As en_OptionDataMaster
Public Enum en_OptionDataMaster
'    opt_No_CompareDataToCtrlBeforeUpdate = -1
'    opt_No_ColorControlIfNeededIsEmpty = -2
'    opt_No_AddingInListIfDataValueAbsent = -4
'    opt_No_ColorControlIfDataValueAbsent = -8
    opt_CompareDataToCtrlBeforeUpdate = 1
    opt_ColorControlIfNeededIsEmpty = 2
    opt_AddingInListIfDataValueAbsent = 4
    opt_ColorControlIfDataValueAbsent = 8
    opt_ManageErrorMessage = 16
    opt_ActiveNewRow = 32
End Enum
 
'Public Enum en_UpdateDone
'    UpD_Done = -1 'Update OK
'    UpD_Error = 0  'Update non effective (erreur lors de la mise à jour  du TS) 'Todo : Voir pour faire remonter le vrai code erreur fourni par  VB
'    UpD_Cancel = 1 'Update annulé par l'utilisateur
'End Enum
 
'NomColonne | NomControle | Obligatoire? | ValeursDefault | ValeursVrai/Alias
Private Enum en_LinkerInfo
    [LkInfo_First] = 1
    lkInfo_ColonneName = 1
    LkInfo_ControlName = 2
    LkInfo_Needed = 3
    lkInfo_DefaultValues = 4
    LkInfo_TrueValues = 5
    LkInfo_Alias = LkInfo_TrueValues
    LkInfo_Captionactif = LkInfo_TrueValues
    LkInfo_FalseValues = 6
    LkInfo_CaptionInActif = LkInfo_FalseValues
    LkInfo_Memoire = 7
    [LkInfo_Last] = 7
End Enum
 
Private Enum en_NameTabInterne
    nti_Linker = 1
    nti_Action = 2
End Enum
 
 
 
'Les actions possibles
Private Const CstListActionsFriendly =  "AfficherIndex,AllerPremièreLigne,AllerDernièreLigne,AllerLigneSuivante,AllerLignePrécédente,AllerLigne-Bouton,AllerLigne-FuturIndex,AjouterLigne,SupprimerLigneActive,MAJData,MAJCtrl,DesactiverMAJ,ViderContrôles,ValeurDefautContrôles,Option-AjoutSiAbsent,Option-ColorerSiAbsent,Option-ColorerSiObligatoire,Option-GestionMessageErreur,Option-ActiverNouvelleLigne"
Private Const CstListActionsShort =  "ShowIndex,MoveFirst,MoveLast,MoveNext,MovePrevious,Move-Cmd,Move-FIndex,AddRow,DelActiveRow,MAJData,MAJCtrl,HSMAJ,ClearCtrl,DefValCtrl,Opt-AddAbs,Opt-ColorAbs,Opt-ColorNeeded,Opt-MsgError,Opt-MoveNewRow"
 
'Les entêtes des tableaux de gestion
Private Const CstListHeadersActions = "Action,Contrôle,Obligatoire,ValeurParDéfaut,Caption_Actif, Caption_Inactif, Mémoire"
Private Const CstListHeadersLinkCtrl = "ChampsData,Contrôle,Obligatoire,ValeursDéfaut,ValeursVRAI-Alias,ValeursFAUX,Mémoire"
'Private pti_List_Actions
'Private pListActionsCtrlType
Private pti_List_HeadersActions
Private pti_List_HeadersLinkCtrls
 
Private Const CstColor_NeedEmpty = &HC0C0FF 'Rouge
Private Const CstColor_UnknownValue = &HFFC0C0 'Violet
Private Const CstColor_Locked = &H80000003  'Barre titre incative
Private Const CstColor_Default = &H80000005   'Fond de la fenêtre
 
 
Private Sub CstArray()
    'pti_List_Actions = Split(CstListActions, ",")
    pti_List_HeadersActions = Split(CstListHeadersActions, ",")
    pti_List_HeadersLinkCtrls = Split(CstListHeadersLinkCtrl, ",")
End Sub
 
 
'#################################################
' Constructeur & Destructure & Init
'#################################################
 
 
Private Sub Class_Initialize()
Dim Short, Friendly, iAct As Integer
 
    'On crée les tableaux de "constantes"
    CstArray
 
    'On crée la collection de la liste de champs
    Set pDataFields = New Cls_TSToDataFields
    pDataFields.SetParent Me
 
    'On crée la collection des Linkers
    Set pDataCtrls = New Cls_TSToDataLinkers
    pDataCtrls.SetParent Me
 
    'On crée la collection des actions
    Set pDataActions = New Cls_TSToDataLinkers
    pDataActions.SetParent 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
    Set pDataActions = Nothing
    Set pDataCtrls = Nothing
End Sub
 
Public Sub InitDataStructur(aParent As UserForm, aDataSource As  ListObject, Optional AutoLinkOptionSheet As Boolean, Optional  Tab_GestionLinkCtrl As ListObject, Optional Tab_GestionAction As  ListObject)
'Nom des tableaux maxi 20 caractères (32 caractères max pour le nom du sheet)
Dim Ws_Options As Worksheet, rgTopLeft As Range, Ws_Memo As Worksheet
Dim ListCtrl As String, ListCtrlAction As String, aCtrl As Control, aCell As Range
Dim QuitteBeforeMAJ As Boolean
Dim StrRacine As String
Dim TS_Finded As ListObject
Dim ti_TMP As Variant
Dim StrUniqueGrp As String, AddUniGrp As Boolean
 
    Set Parent = aParent
    SetTab_Data aDataSource
    If Not Tab_GestionAction Is Nothing Then Set pTab_Actions = Tab_GestionAction
    If Not Tab_GestionLinkCtrl Is Nothing Then Set pTab_Ctrls = Tab_GestionLinkCtrl
 
    StrRacine = aDataSource.Name
 
    'On regarde si la liaison automatique est activée
    If AutoLinkOptionSheet Then
        'On regarde si les tableau existent déjà
 
        'Celui qui servira pour faire la liaison CtrlUserForm-DataTS
        'On regarde s'il n'est pas déjà présent dans le classeur
        Set pTab_Ctrls = FindTS("Tab_LinkCtrls_" & StrRacine)
        'S'il est absent (nothing), il sera créé plus tard
 
        'Le tableau qui permet de pointer les Ctrls de commande de la BdD
        'On regarde s'il n'est pas déjà présent dans le classeur
        Set pTab_Actions = FindTS("Tab_Actions_" & StrRacine)
        'S'il est absent (nothing), il sera créé plus tard
 
        'On regarde si au moins un des deux tableaux est absent
        If (pTab_Ctrls Is Nothing) Or (pTab_Actions Is Nothing) Then
            'On bloque la mise à jour de l'écran
            Application.ScreenUpdating = False
 
            'Au moins un des tableaux n'existe pas
            'On regarde si la feuille existe déjà
            On Error Resume Next
                Set Ws_Options = ThisWorkbook.Worksheets("Gestion_" & StrRacine)
            On Error GoTo 0
 
            If Not Ws_Options Is Nothing Then
                'La feuille existe déjà
            Else
                'La feuille n'existe pas
                'On mémorise la feuille active
                Set Ws_Memo = ThisWorkbook.ActiveSheet
                'On crée la feuille
                Set Ws_Options = ThisWorkbook.Worksheets.Add
 
                'On le renome
                Ws_Options.Name = "Gestion_" & StrRacine
 
                'On redéfini le sheet actif
                Ws_Memo.Activate
            End If
 
            'On lui ajoute les tableaux manquant
            'Lien Ctrl - Data
            If pTab_Ctrls Is Nothing Then
                'On récupère les entêtes de colonne
                Set pTab_Ctrls = CreateInfoTS(Ws_Options,  "Tab_LinkCtrls_" & StrRacine, "TableStyleMedium10",  pti_List_HeadersLinkCtrls, Transpose_ti(pTab_Data.HeaderRowRange.Value))
            End If
 
            'Controle BdD
            If pTab_Actions Is Nothing Then
                Set pTab_Actions = CreateInfoTS(Ws_Options,  "Tab_Actions_" & StrRacine, "TableStyleMedium9",  pti_List_HeadersActions, Transpose_ti(Split(CstListActionsFriendly,  ",")))
            End If
            'On débloque la mise à jour de l'écran
            Application.ScreenUpdating = True
 
            'On informe l'utilisateur
            If MsgBox("Les tableaux de configuartion sont prêts,  souhaitez-vous basculer sur la feuille?", vbInformation + vbYesNo,  "Basculer vers la gestion?") = vbYes Then QuitteBeforeMAJ = True
        End If
    End If
 
 
    'On Met à jour les listes de validation
    If Not pTab_Ctrls Is Nothing Then
        '########## Controles Affichage
        'On crée la liste des controles présents sur le UF (uniquement ceux compatibles)
        'Init
        StrUniqueGrp = CstDelim1
        For Each aCtrl In Parent.Controls
            AddUniGrp = False
            Select Case LCase(TypeName(aCtrl))
                Case "label", "textbox", "combobox", "listbox"
                    AddUniGrp = True
                Case "checkbox", "optionbutton"
                    'On regarde si le groupe est déjà représenté
                    If aCtrl.GroupName <> "" Then
                        If InStr(1, StrUniqueGrp, CstDelim1 & aCtrl.GroupName & CstDelim1, vbTextCompare) = 0 Then
                            'On ajoute le control à la liste et on ajoute le nom du groupe
                            AddUniGrp = True
                            StrUniqueGrp = StrUniqueGrp & CstDelim1
                        End If
                    Else
                        'Les option bouton ou checkbox isolé(e)s sont ajouté(e)s
                        AddUniGrp = True
                    End If
            End Select
            If AddUniGrp Then
                If ListCtrl <> vbNullString Then ListCtrl = ListCtrl & CstDelim1
                ListCtrl = ListCtrl & aCtrl.Name
            End If
        Next
        'On trie la liste
        ListCtrl = Join(Trier_ti(Split(ListCtrl, CstDelim1)), ",")
 
        'On met en place les validation
        StockListValidation pTab_Ctrls, "TableStyleMedium3", "CtrlList", ListCtrl
    End If
 
 
 
    If Not pTab_Actions Is Nothing Then
        '########## Controles Action
        'On crée la liste des controles présents sur le UF (uniquement ceux compatibale + CommandButton)
        ListCtrlAction = Replace(ListCtrl, ",", ";")
        For Each aCtrl In Parent.Controls
            Select Case LCase(TypeName(aCtrl))
                Case "commandbutton"
                    If ListCtrlAction <> vbNullString Then ListCtrlAction = ListCtrlAction & CstDelim1
                    ListCtrlAction = ListCtrlAction & aCtrl.Name
            End Select
        Next
        'On trie la liste
        ListCtrlAction = Join(Trier_ti(Split(ListCtrlAction, CstDelim1)), ",")
 
        'On met en place les validation
        StockListValidation pTab_Actions, "TableStyleMedium2", "CtrlList", ListCtrlAction
    End If
 
    If QuitteBeforeMAJ Then
        'On active la page et on ferme le Userform
        Ws_Options.Activate
        'End
    End If
 
    'Si des tableaux existent, on tente d'utiliser leur contenu pour créer les Linkers
    If Not pTab_Ctrls Is Nothing Then
        If Load_tiStructureForGab(ti_TMP, pTab_Ctrls.Range.Value) = 0 Then tiStructurCtrl = ti_TMP
    End If
 
    If Not pTab_Actions Is Nothing Then
        If Load_tiStructureForGab(ti_TMP, pTab_Actions.Range.Value) = 0 Then tiStructurAction = ti_TMP
    End If
 
    'On pointe le 1er enregistrement si existant
    If pDataFields.RowCount > 0 Then pDataFields.MoveToRow 1
    'Gestion des Controls
    GestionEtat_Ctrl
    GestionMoveCombo True
 
End Sub
 
 
 
 
'#################################################
' Function Internes
'#################################################
 
 
Private Function StockListValidation(TabCible As ListObject, TabStyle As  String, Entete As String, CommaListValues As String) As String
Dim TabValidation As ListObject
Dim iCol As Integer
Dim Wb As Workbook, LName As Name
Dim TS_Name As String
Dim tiValid As Variant
 
    'On vérifie si le tableau existe déjà
    TS_Name = "Tab_Valid_" & TabCible.Name
    Set TabValidation = FindTS(TS_Name)
 
    If TabValidation Is Nothing Then
    'On vérifie si la liste des controles dépasse la limite autorisé par Validation
        If Len(CommaListValues) > 255 Then
            'On crée un nouveau tableau sur une colonne libre
            With TabCible.DataBodyRange.Worksheet
                'On cherche une colonne libre
                iCol = .UsedRange.Cells(1, 1).Column + .UsedRange.Columns.Count + 1
                'On crée le tableau
                Set TabValidation =  CreateInfoTS(TabCible.DataBodyRange.Worksheet, TS_Name, TabStyle,  Array(Entete), Split(CommaListValues, ","), 1, iCol)
                'On masque la liste
                .Columns(iCol).Hidden = True
            End With
        Else
            'On utilise directement la list en Validation
            StockListValidation = CommaListValues
        End If
    End If
 
 
    If Not TabValidation Is Nothing Then
        'On pointe le classeur
        Set Wb = TabCible.DataBodyRange.Worksheet.Parent
        'On cherche la plage nommée correspondante
        'On la crée / met à jour (préférable de faire une mise à jour au cas ou le tableau aurait été détruit, puis refait
        StockListValidation = "L_" & TabValidation.Name
        Set LName = Wb.Names.Add(StockListValidation, "=" & TabValidation.Name & "[" & Entete & "]")
        'On pointe la plage nommée sans = ni "
 
        'On vide le tableau et on met à jour
        If TabValidation.ListRows.Count > 0 Then TabValidation.DataBodyRange.Delete xlUp
        tiValid = Split(CommaListValues, ",")
        On Error Resume Next
            TabValidation.HeaderRowRange.OffSet(1).Resize(UBound(tiValid) + 1).Value = Transpose_ti(tiValid)
        On Error GoTo 0
    End If
 
    'On met à jour la colonne Ctrl
    With TabCible.ListColumns("Contrôle").DataBodyRange.Validation
        .Delete
        .Add xlValidateList, Formula1:="=" & StockListValidation
        'On laisse la possibilité de saisir d'autre Controls qui auraient été ajouté après la création
        .ShowInput = False
        .ShowError = False
    End With
 
    With TabCible.ListColumns("Obligatoire").DataBodyRange.Validation
        .Delete
        .Add xlValidateList, Formula1:="VRAI,FAUX"
    End With
 
 
 
End Function
 
Private Function FindShortName(FriendlyName As String) As String
Dim tab_Friendly, tab_Short
Dim iAct As Integer
 
    tab_Friendly = Split(CstListActionsFriendly, ",")
    tab_Short = Split(CstListActionsShort, ",")
 
    For iAct = 0 To UBound(tab_Short)
        If tab_Friendly(iAct) = FriendlyName Then
            FindShortName = tab_Short(iAct)
            Exit For
        End If
    Next
End Function
 
Private Function LinkerByShortAction(ShortName As String) As Cls_TSToDataLinker
Dim tab_Friendly, tab_Short
Dim iAct As Integer
 
    tab_Friendly = Split(CstListActionsFriendly, ",")
    tab_Short = Split(CstListActionsShort, ",")
 
    'On fait le switch entre les deux
    For iAct = 0 To UBound(tab_Short)
        If tab_Short(iAct) = ShortName Then
            Set LinkerByShortAction = pDataActions.Linker(tab_Friendly(iAct))
            Exit For
        End If
    Next
End Function
 
Private Function Trier_ti(ti_STab As Variant) As Variant 'Tableau Simple 1 dimension
Dim ti_TMP As Variant
Dim iTab As Integer, iTmp As Integer, iTot As Integer
Dim iAdd As Integer
 
    'On dimensionne
    ReDim ti_TMP(LBound(ti_STab) To UBound(ti_STab))
    iTab = LBound(ti_STab)
    iAdd = -1
 
    'On boucle sur les valeurs à trier
    While iTab <= UBound(ti_STab)
        iTmp = LBound(ti_TMP)
        iAdd = -1
        While (iTmp <= UBound(ti_TMP)) And iAdd = -1
            'On compare
            If (ti_TMP(iTmp) = vbNullString) Then
                'On placera ici
                iAdd = iTmp
            Else
                If StrComp(ti_TMP(iTmp), ti_STab(iTab)) = 1 Then
                    'On inserera ici
                    iAdd = iTmp
                    'On décale tout ce qui est déjà rempli vers le bas
                    For iTmp = iTab To iAdd + 1 Step -1
                        ti_TMP(iTmp) = ti_TMP(iTmp - 1)
                    Next
                End If
            End If
            'On ajoute si besoin
            If iAdd <> -1 Then
                ti_TMP(iAdd) = ti_STab(iTab)
            End If
            iTmp = iTmp + 1
        Wend
        iTab = iTab + 1
    Wend
 
    'On retourne le tableau trié
    Trier_ti = ti_TMP
 
End Function
 
Private Function FindTS(TS_Name As String) As ListObject
Dim iSheet As Integer
 
    With ThisWorkbook.Worksheets
        iSheet = 1
        Do While (iSheet <= .Count) And (FindTS Is Nothing)
            On Error Resume Next
                Set FindTS = .Item(iSheet).ListObjects(TS_Name)
            On Error GoTo 0
            iSheet = iSheet + 1
        Loop
    End With
End Function
 
Private Function CreateInfoTS(Ws_Options As Worksheet, TS_Name As  String, TabStyle As String, listEntetes As Variant, listFirstColonne As  Variant, Optional iForceRow As Integer, Optional iForceCol As Integer)  As ListObject
Dim rgTopLeft As Range
Dim iRow As Integer, iCol As Integer
    'On choisi un emplacement libre
    With Ws_Options
 
        'On pointe une cellule se trouvant en 1ère colonne libre ou  iForceCol et 5 lignes en dessous de la zone déjà occupée ou iForceRow
        iCol = IIf(iForceCol <> 0, iForceCol, .UsedRange.Cells(1, 1).Column + .UsedRange.Columns.Count + 1)
        iRow = IIf(iForceRow <> 0, iForceRow, .UsedRange.Cells(1, 1).Row + .UsedRange.Rows.Count + 5)
        Set rgTopLeft = .Cells(iRow, iCol)
 
        'On place les valeurs d'entête
        rgTopLeft.Resize(columnSize:=UBound(listEntetes) + 1).Value = listEntetes
 
        'Puis les valeur de la 1ère colonne
        rgTopLeft.OffSet(1).Resize(UBound(listFirstColonne)).Value = listFirstColonne
 
        'On pointe l'ensemble pour créer un tableau structuré
        Set CreateInfoTS = .ListObjects.Add(xlSrcRange, rgTopLeft.CurrentRegion, , xlYes)
 
        'On le renome et on le met en forme...
        With CreateInfoTS
            .Name = TS_Name
            .ShowTableStyleFirstColumn = True
            On Error Resume Next
                .TableStyle = TabStyle
            On Error GoTo 0
            .ListColumns(1).Range.EntireColumn.AutoFit
        End With
    End With
 
End Function
 
'NomColonne | NomControle | Obligatoire? | ValeursDefault | ValeursVRAI/Alias | ValeursFAUX
'Bug : Type enum privé interdit dans function public
Private Function GetLinkerRawInfo(LkInfo As en_LinkerInfo, ByVal tiLinkerTab As Variant, ByVal LkName As String) As String
Dim iRow As Integer
    'On vérifie que le tableau est dispo
    If IsArray(tiLinkerTab) Then
        'On recherche le nom dans la liste
        For iRow = 1 To UBound(tiLinkerTab)
            If tiLinkerTab(iRow, lkInfo_ColonneName) = LkName Then
                'On retourne l'information demandée 'Note: On laisse faire la gestion d'erreur par VBE?
                GetLinkerRawInfo = tiLinkerTab(iRow, LkInfo)
                Exit For
            End If
        Next
    End If
End Function
 
Private Function Load_tiStructureForGab(ByRef ti_Cible As Variant, ti_Tab As Variant) As Long
'Utiliser pour les ti Linker et Action
'Le tableau doit avoir les colonnes en tête dans l'odre
'ErrLvl: 8      - tableau fourni non conforme
Dim D2 As Byte
Dim ErrorState As Long
Dim ti_Conforme As Variant
 
    'On passe le tableau au gabari
    ti_Conforme = GabarisationTab(ti_Tab)
    'On vérifie que c'est un tableau
    If VarType(ti_Conforme) Then
        'On mémorise les infos
        ti_Cible = ti_Conforme
    Else
        ErrorState = ti_Conforme
    End If
 
    Load_tiStructureForGab = ErrorState
End Function
 
Private Function GabarisationTab(ti_Tab As Variant) As Variant
'Passage en base0 niveau ligne et base 1 niveau colonne
'But le traitement par la suite du tabelau comme étant en base 0 (0  contenant les entêtes), on ne tiendra pas compte des entêtes ->  simili tableau en base 1
Dim D1 As Integer, D2 As Integer
Dim iR As Long, iC As Long
Dim OffSetR As Integer, OffSetC As Integer
Dim ti_Correct As Variant
 
    If IsArray(ti_Tab) Then 'Sinon on laisse faire la gestion d'erreur VBE
        'On effectue la correction de base si necessaire
        If LBound(ti_Tab) = 1 Or LBound(ti_Tab, 2) = 0 Then
            'On calcul les nouvelles bornes
            'On calcul les offset qu'il faudra faire
            OffSetR = -LBound(ti_Tab)
            OffSetC = 1 - LBound(ti_Tab, 2)
            'Pour la ligne on ramène à 0
            D1 = UBound(ti_Tab) + OffSetR
            D2 = UBound(ti_Tab, 2) + OffSetC
            'On redimensionne
            ReDim ti_Correct(0 To D1, 1 To D2)
            'On boucle
            iR = 1
            While (iR <= UBound(ti_Tab))
                iC = 1
                While (iC <= D2)
                    ti_Correct(iR + OffSetR, iC + OffSetC) = ti_Tab(iR, iC)
                    iC = iC + 1
                Wend
                iR = iR + 1
            Wend
            'On retourne le tableau obtenu
            GabarisationTab = ti_Correct
        End If
 
    Else
        GabarisationTab = 8
    End If
 
End Function
 
 
 
 
'#################################################
' Functions Externes
'#################################################
 
'Bug, l'utilisation des Enum empêche d mettre en public
Private Function SayIsTrueFalseNull(aValue As Variant, ByVal LinkerName As String, ti_LinkerTab As Variant)
Dim EtatList As String, TrueExist As Boolean, FalseExist As Boolean
Dim Retour As Variant
 
    If VarType(aValue) = vbBoolean Then
        SayIsTrueFalseNull = aValue
    Else
        'On traite la valeur pour voir si c'est un VRAI, un FAUX ou un  ---(3ème état, tout autre valeur que True ou False) en fonction de  donnée
        EtatList = GetLinkerRawInfo(LkInfo_TrueValues, ti_LinkerTab, LinkerName)
        'On vérifie si la valeur transmise existe
        TrueExist = InStr(1, CstDelim1 & EtatList & CstDelim1,  CstDelim1 & aValue & CstDelim1, vbTextCompare) = 0
 
        'On traite la valeur pour voir si c'est un VRAI, un FAUX ou un  ---(3ème état, tout autre valeur que True ou False) en fonction de  donnée
        EtatList = GetLinkerRawInfo(LkInfo_FalseValues, ti_LinkerTab, LinkerName)
        'On vérifie si la valeur transmise existe
        FalseExist = InStr(1, CstDelim1 & EtatList & CstDelim1,  CstDelim1 & aValue & CstDelim1, vbTextCompare) = 0
 
        'On en déduit la valeur
        SayIsTrueFalseNull = IIf(TrueExist = FalseExist, vbNull, TrueExist)
    End If
 
End Function
 
Public Function IsSameDataAndCtrl() As Boolean
Dim iLCtrl As Integer
 
    'Init
    IsSameDataAndCtrl = True
 
    For iLCtrl = 0 To pDataCtrls.Count
        'On vérifie qu'il existe un ctrl lié
        If pDataCtrls.Linker(iLCtrl).IsLinked Then
            'On compare les deux valeurs
            If pDataCtrls.Linker(iLCtrl).Value <> pDataFields.Field(pDataCtrls.Linker(iLCtrl).Name).DataValue Then
                IsSameDataAndCtrl = False
                Exit For
            End If
        End If
    Next
 
End Function
 
Public Sub SetCtrlDefaultValues()
Dim ti_Trans As Variant
 
    'Todo: On vérifie si l'enregistrement est nécessaire + Gestion Message Erreur Option
    'On compare les données de la base avec le contenu des controles
 
    'On va chercher les valeurs par defaut qu'on place dans un tableau
    If ExtractInfo(pti_TabCtrls, Array(lkInfo_ColonneName, lkInfo_DefaultValues), ti_Trans) = 0 Then
        'On transmet le tableau
        pDataCtrls.SetValues ti_Trans
    End If
 
End Sub
 
Public Function CreateLinkCtrls(ti_CreateCtrls As Variant) As Long
Dim ErrorState As Long
Dim ti_TMP As Variant
    'On gabarise de tableau
    ErrorState = Load_tiStructureForGab(ti_TMP, ti_CreateCtrls)
    'On transmet pour création des linkers Ctrls
    If ErrorState = 0 Then tiStructurCtrl = ti_TMP
 
End Function
 
Public Function CreateLinkActions(ti_CreateAction As Variant) As Long
Dim ErrorState As Long
Dim ti_TMP As Variant
    'On gabarise de tableau
    ErrorState = Load_tiStructureForGab(ti_TMP, ti_CreateAction)
    'On transmet pour création des linkers Ctrls
    If ErrorState = 0 Then tiStructurAction = ti_TMP
 
End Function
 
Public Function CreateLinkersByControlTag() As Boolean 'Todo faire la gestion d'erreur
 
'\[Linker(?:=(Ctrl|Action)){0,1}\](\w+)\|(?:(Vrai|Faux)){0,1}\|(?:(.[^|;]+)){0,1}\|(?:(.[^|]+)){0,1}\[\/Linker]
 
'On boucle sur les controls du Useform pour créer les liens ou on ne le fait que pour le control précisé
'Le contenu du tag doit être inscrit de la sorte
'[Linker=Ctrl ou Action]NomColonneLiée|ValeurVraie1;Obligatoire?(Vrai ou  Faux);ValeurVraie2;...|ValeurFausse1;ValeurFausse2;...[/Linker]
'Exemple pour le contrôle optionbouton Option1:
'Contenu du Tag =  [Linker=Ctrl]Option1|Vrai|Ligne1DéfautCol1|Col2;Ligne2DefalutCol1|;Ligne3DefautCol1|Col2|Choix1A;Choix1B;Choix1C;Choix1D|Faux1;Faux2;Faux3[/Linker]
'Probème sur la valeur par défaut des list/comboBox Colonne1|Colonne2
 
Dim RegExpTag As Object 'RegExp
Dim Match As Object 'VBScript_RegExp_55.Match
Dim Matches As Object 'VBScript_RegExp_55.MatchCollection
 
Dim Ctrl As MSForms.Control, iCtrl As Integer
Dim ti_Ctrls_TMP, ti_Actions_TMP
Dim iRowCtrl As Integer, iRowAction As Integer, iCol As Integer, NbrRowSup As Integer
 
 
    'On initialise
    CreateLinkersByControlTag = True
 
    Set RegExpTag = CreateObject("VBScript.RegExp") 'New RegExp
 
 
    RegExpTag.Pattern =  "\[Linker(?:=(Ctrl|Action)){0,1}\](.+)\|(?:(Vrai|Faux)){0,1}\|(?:(.+)){0,1}\|(?:(.[^|]+)){0,1}\|(?:(.[^|]+)){0,1}\[\/Linker]"
    RegExpTag.IgnoreCase = True
    RegExpTag.Global = True
 
    'On construit les tableaux internes, avec 5 lignes pour commencer -- (Col,Ligne) il seront transposés à la fin
    ReDim ti_Ctrls_TMP(1 To UBound(pti_List_HeadersLinkCtrls), 0 To 4)
    ReDim ti_Actions_TMP(1 To UBound(pti_List_HeadersActions), 0 To 4)
 
    'On place les entêtes sur la ligne 0
    For iCol = 1 To UBound(ti_Ctrls_TMP)
        ti_Ctrls_TMP(iCol, 0) = pti_List_HeadersLinkCtrls(0, iCol)
    Next
    For iCol = 1 To UBound(ti_Actions_TMP)
        ti_Actions_TMP(iCol, 0) = pti_List_HeadersActions(0, iCol)
    Next
 
    'On pointe les 1ère lignes où seront inscrite les données
    iRowCtrl = 1
    iRowAction = 1
 
    'On boucle
    For Each Ctrl In pParent.Controls
        'On test le tag dans le regexp
        If RegExpTag.test(Ctrl.Tag) Then
            'On récupère la 1ère correspondance
            Set Match = RegExpTag.Execute(Ctrl.Tag)(0)
 
            'On regarde si les tableaux doivent être élargis
            If UBound(ti_Ctrls_TMP) < iRowCtrl Then ReDim Preserve  ti_Ctrls_TMP(1 To UBound(ti_Ctrls_TMP), 0 To UBound(ti_Ctrls_TMP, 2) +  5)
            If UBound(ti_Actions_TMP) < iRowAction Then ReDim  Preserve ti_Actions_TMP(1 To UBound(ti_Actions_TMP), 0 To  UBound(ti_Actions_TMP, 2) + 5)
 
            'La 1ère subchaine nous indique si c'est un Ctrl ou une Action
            'On ajoute les informations dans le tableau idoïne
            If Match.SubMatches(1) = "Action" Then
                'Le nom de l'Action associée
                ti_Actions_TMP(1, iRowCtrl) = Match.SubMatches(2)
                'Le nom du Controle
                ti_Actions_TMP(2, iRowCtrl) = Ctrl.Name
                'Le reste : Obligatoire,ValeurDefaut, ValeursVRAI, ValeurFAUX
                For iCol = 3 To UBound(ti_Actions_TMP)
                    ti_Actions_TMP(iCol, iRowCtrl) = Match.SubMatches(iCol)
                Next
 
            Else 'Ctrl Choix par défaut si omis
                'Le nom du Champs associé
                ti_Ctrls_TMP(1, iRowCtrl) = Match.SubMatches(2)
                'Le nom du Controle
                ti_Ctrls_TMP(2, iRowCtrl) = Ctrl.Name
                'Le reste : Obligatoire,ValeurDefaut, ValeursVRAI, ValeurFAUX
                For iCol = 3 To UBound(ti_Ctrls_TMP)
                    ti_Ctrls_TMP(iCol, iRowCtrl) = Match.SubMatches(iCol)
                Next
            End If
        End If
    Next
 
    'On supprime les lignes vides
    iRowCtrl = UBound(ti_Ctrls_TMP)
    NbrRowSup = 0
    Do While ti_Ctrls_TMP(0, iRowCtrl) = vbNullString And (iRowCtrl > 0)
        NbrRowSup = NbrRowSup + 1
        iRowCtrl = iRowCtrl - 1
    Loop
    ReDim Preserve ti_Ctrls_TMP(1 To UBound(ti_Ctrls_TMP), 0 To UBound(ti_Ctrls_TMP, 2) - NbrRowSup)
 
    iRowAction = UBound(ti_Actions_TMP)
    Do While ti_Actions_TMP(0, iRowAction) = vbNullString And (iRowAction > 0)
        NbrRowSup = NbrRowSup + 1
        iRowAction = iRowAction - 1
    Loop
    ReDim Preserve ti_Actions_TMP(1 To UBound(ti_Actions_TMP), 0 To UBound(ti_Actions_TMP, 2) - NbrRowSup)
 
    'On transmet les tableaux pour lancer la création des Linkers 'On transpose les resultats
    tiStructurCtrl = Transpose_ti(ti_Ctrls_TMP)
    tiStructurAction = Transpose_ti(ti_Actions_TMP)
End Function
 
 
'#################################################
' Propriétés DataMaster
'#################################################
 
 
Public Property Get DataFields() As Cls_TSToDataFields
    Set DataFields = pDataFields
End Property
 
Public Property Get LinkerCtrl() As Cls_TSToDataLinkers
    Set LinkerCtrl = pDataCtrls
End Property
 
Public Property Get LinkerActions() As Cls_TSToDataFields
    Set LinkerActions = pDataActions
End Property
 
Public Property Get Controls() As Controls
    If Not pParent Is Nothing Then Set Controls = pParent.Controls
End Property
 
Public Property Get DataReadOnly() As Boolean
    DataReadOnly = pDataFields.ReadOnly
End Property
 
Public Property Let DataReadOnly(aValue As Boolean)
    pDataFields.ReadOnly = aValue
    'On met à jour le bouton associé si existant 'On change le caption du bouton
    With LinkerByShortAction("HSMAJ")
        If .IsLinked Then
            .Value = IIf(aValue, GetLinkerRawInfo(LkInfo_CaptionInActif,  pti_TabActions, .Name), GetLinkerRawInfo(LkInfo_Captionactif,  pti_TabActions, .Name))
        End If
    End With
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 Tab_Data() As ListObject 'lecture seul
    Set Tab_Data = pTab_Data
End Property
 
Public Property Let Option_AddingInListIfDataValueAbsent(Value As Boolean)
    SetOptions IIf(Value, pOptions Or opt_AddingInListIfDataValueAbsent,  Not (Not pOptions Or opt_AddingInListIfDataValueAbsent))
End Property
 
Public Property Let Option_ColorControlIfDataValueAbsent(Value As Boolean)
    SetOptions IIf(Value, pOptions Or opt_ColorControlIfDataValueAbsent,  Not (Not pOptions Or opt_ColorControlIfDataValueAbsent))
End Property
 
Public Property Let Option_ColorControlIfNeededIsEmpty(Value As Boolean)
    SetOptions IIf(Value, pOptions Or opt_ColorControlIfNeededIsEmpty, Not (Not pOptions Or opt_ColorControlIfNeededIsEmpty))
End Property
 
Public Property Let Option_ManageErrorMessage(Value As Boolean)
    SetOptions IIf(Value, pOptions Or opt_ManageErrorMessage, Not (Not pOptions Or opt_ManageErrorMessage))
End Property
 
Public Property Let Option_ActiveNewRow(Value As Boolean)
    SetOptions IIf(Value, pOptions Or opt_ActiveNewRow, Not (Not pOptions Or opt_ActiveNewRow))
End Property
 
Public Property Get Option_AddingInListIfDataValueAbsent() As Boolean
Option_AddingInListIfDataValueAbsent = pOptions And opt_AddingInListIfDataValueAbsent
End Property
 
Public Property Get Option_ColorControlIfDataValueAbsent() As Boolean
Option_ColorControlIfDataValueAbsent = pOptions And opt_ColorControlIfDataValueAbsent
End Property
 
Public Property Get Option_ColorControlIfNeededIsEmpty() As Boolean
Option_ColorControlIfNeededIsEmpty = pOptions And opt_ColorControlIfNeededIsEmpty
End Property
 
Public Property Get Option_ManageErrorMessage() As Boolean
Option_ManageErrorMessage = pOptions And opt_ManageErrorMessage
End Property
 
Public Property Get Option_ActiveNewRow() As Boolean
Option_ActiveNewRow = pOptions And opt_ActiveNewRow
End Property
 
Public Sub SetOptions(aValue As en_OptionDataMaster)
    pOptions = aValue
 
    'On met à jour les checkbox liés si existants
    If LinkerByShortAction("Opt-AddAbs").IsLinked Then  LinkerByShortAction("Opt-AddAbs").Enabled = aValue And  opt_AddingInListIfDataValueAbsent
    If LinkerByShortAction("Opt-ColorAbs").IsLinked Then  LinkerByShortAction("Opt-ColorAbs").Enabled = aValue And  opt_ColorControlIfDataValueAbsent
    If LinkerByShortAction("Opt-ColorNeeded").IsLinked Then  LinkerByShortAction("Opt-ColorNeeded").Enabled = aValue And  opt_ColorControlIfNeededIsEmpty
    If LinkerByShortAction("Opt-MsgError").IsLinked Then  LinkerByShortAction("Opt-MsgError").Enabled = aValue And  opt_ManageErrorMessage
    If LinkerByShortAction("Opt-MoveNewRow").IsLinked Then  LinkerByShortAction("Opt-MoveNewRow").Enabled = aValue And  opt_ActiveNewRow
End Sub
 
Public Function GetOptions() As en_OptionDataMaster
    pOptions = pOptions
End Function
 
Private Function SetTab_Data(ByRef aTab_Data As ListObject) As Long
'ErrLvl: 16384 - Impossible de changer de DataBase en cours d'instance
    'On s'assure d'interdire les changements de Base en cours d'instance
    If pTab_Data Is Nothing Then
        Set pTab_Data = aTab_Data
        SetTab_Data = pDataFields.SetTab_Data(aTab_Data)
    Else
        SetTab_Data = 16384
    End If
End Function
 
Public Sub MoveToFirstRow()
    pDataFields.MoveToFirstRow
End Sub
 
Public Sub MoveToLastRow()
    pDataFields.MoveToLastRow
End Sub
 
Public Sub MoveToNextRow()
    pDataFields.MoveToNextRow
End Sub
 
Public Sub MoveToPreviousRow()
    pDataFields.MoveToPreviousRow
End Sub
 
Public Function MoveToRow(Index As Integer) As Long
    MoveToRow = pDataFields.MoveToRow(Index)
End Function
 
Public Sub AddRow()
    pDataFields.AddRow
End Sub
 
Public Sub DeleteRow()
    pDataFields.DeleteRow
End Sub
 
Public Function UpdateDataField(tiValues As Variant) As Long
    UpdateDataField = pDataFields.UpdateDataField(tiValues)
End Function
 
Public Function SetCtrlsValues(Values As Variant, Optional ClearMissing As Boolean = True) As Long
    SetCtrlsValues = pDataCtrls.SetValues(Values)
End Function
 
Public Function GetCtrlValues() As Variant
    GetCtrlValues = pDataCtrls.GetValues
End Function
 
Public Function GetDataValues() As Variant
    GetDataValues = pDataFields.GetValues
End Function
 
Public Sub ClearCtrlsContents()
    pDataCtrls.ClearContents
End Sub
 
'#################################################
' Propriétés Linkers
'#################################################
 
Private Property Let tiStructurCtrl(ati_Tab As Variant)
Dim iTab As Integer
    pti_TabCtrls = ati_Tab
    'On redimenssionne le tableau qui contiendra les couleur par defaut
    ReDim DefaultBackColor(1 To UBound(ati_Tab))
 
    'On transmet le tableau au linkers pour qu'il crée le linker(s)
    If pDataCtrls.InitLinkers(Me, ati_Tab) = 0 Then
        'On conserve la couleur de fond du controle
        iTab = 1
        While iTab <= UBound(ati_Tab)
            DefaultBackColor(iTab) = pParent.Controls(ati_Tab(iTab, 2)).BackColor
            iTab = iTab + 1
        Wend
    End If
 
End Property
 
Public Property Get tiStructurCtrl() As Variant
    tiStructurCtrl = pti_TabCtrls
End Property
 
Private Function ExtractConfigLinker(it_Structure As Variant) As Variant
Dim it_Config As Variant, varTmp As Variant
Dim iRow As Integer
Dim ListAtt
 
    'Ca ne va pas, le nom de l'attribu et de l'entête ne correspondent pas.
 
'    'Initi it
'    ListAtt = VBA.Array("IsNeeded") ',"Caption","value"... Attention  ils n'impacteront pas tous les Controls en fonction de leur type
'    'On adapte en Fct° du nombre d'attributs (ligne = NbrCtrl x NbrAttributs)
'    ReDim it_Config(0 To UBound(it_Structure) * (UBound(ListAtt) + 1), 1 To 3)
'
'    'On selectionne les valeurs fournies dans TabCtrl qui correspondent à des attributs de Linker
'    'Pour l'instant "Obligatoire"
'    'On boucle sur les valeurs
'    For iRow = 1 To UBound(it_Config) 'On ignore la ligne 1 (entête)
'        'On place le nom champs/action
'        it_Config(iRow, 1) = it_Structure(iRow, 1)
'        'L'attribue
'        it_Config(iRow, 2) = "IsNeeded"
'        'La valeur (boolean)
'        varTmp = GetLinkerRawInfo(LkInfo_Needed
'
 
End Function
 
Private Function ExtractInfo(ByVal ti_Source As Variant, ListeInfo As  Variant, ByRef ti_retour As Variant) As Long 'Todo : Traitement erreur
'ListeInfo = array(n°Colonne,...)
Dim iInfo As Integer, iRow As Integer
 
    'Il faut connaitre le nombre d'info demandées dans listInfo, donc le nombre de bits à 1
    If IsArray(ListeInfo) Then
        'On vérifie q'une demande d'info soit bien présente
        If UBound(ListeInfo) - LBound(ListeInfo) > -1 Then
            'On redimensionne le tableau de retour
            ReDim ti_retour(LBound(ti_Source) To UBound(ti_Source), 1 To UBound(ListeInfo) + (1 - LBound(ListeInfo)))
 
            'On boucle sur les infos
            iInfo = LBound(ListeInfo)
            While iInfo <= UBound(ListeInfo)
                If ListeInfo(iInfo) > 0 And ListeInfo(iInfo) <= UBound(ti_Source) Then
                    'On met en place les valeur dans ce
                    'On boucle sur le contenu de la base
                    For iRow = LBound(ti_Source) To UBound(ti_Source)
                        ti_retour(iRow, iInfo + (1 - LBound(ListeInfo))) = ti_Source(iRow, ListeInfo(iInfo))
                    Next
                Else
                End If
                iInfo = iInfo + 1
            Wend
        Else
            'Pas d'info demandée
        End If
    Else
    End If
End Function
 
Private Function RefreshBackColor(CallerLinker As Cls_TSToDataLinker) As OLE_COLOR
Dim Need As Boolean, StrNeed As String
Dim NewColor As OLE_COLOR, Cancel As Boolean, UpDateColor As Variant
 
    'On priorise la coloration du champs obligatoire vide
    If (pOptions And opt_ColorControlIfNeededIsEmpty) Then
        If CallerLinker.Value = vbNullString Then
            'On regarde si l'élément est obligatoire et vide
            StrNeed = GetLinkerRawInfo(LkInfo_Needed, pti_TabCtrls, CallerLinker.Name)
            If StrNeed <> vbNullString Then Need = CBool(StrNeed)
 
            'On revoit la coloration
            If Need Then UpDateColor = CstColor_NeedEmpty
        Else
            'On reset la couleur de fond
            UpDateColor = DefaultBackColor(CallerLinker.Index)
        End If
    End If
 
    'On modifie la coloration si option Valeur absente dans list
    If (pOptions And opt_ColorControlIfDataValueAbsent) And Not Need Then
        'On revoit la coloration
        If CallerLinker.IsUnknowValue Then
            UpDateColor = CstColor_UnknownValue
        Else
            UpDateColor = DefaultBackColor(CallerLinker.Index)
        End If
    End If
 
    If Not IsEmpty(UpDateColor) Then
        NewColor = UpDateColor
        RaiseEvent CtrlBeforeRefreshColorBack(CallerLinker, NewColor, Cancel)
        If Not Cancel Then CallerLinker.BackColor = NewColor
        RaiseEvent CtrlAfterRefreshColorBack(CallerLinker, Cancel)
    End If
 
End Function
 
Public Sub RefreshAllCtrlBackcolor()
Dim iLinker As Integer
    iLinker = 1
    While iLinker <= pDataCtrls.Count
        RefreshBackColor pDataCtrls.Linker(iLinker)
        iLinker = iLinker + 1
    Wend
End Sub
 
 
 
 
'#################################################
' Propriétés Action
'#################################################
 
 
Private Property Let tiStructurAction(ati_Tab As Variant)
    pti_TabActions = ati_Tab
    'On transmet le tableau au linkers pour qu'il crée le linker(s)
    pDataActions.InitLinkers Me, ati_Tab
End Property
 
Public Property Get tiStructurAction() As Variant
    tiStructurAction = pti_TabActions
End Property
 
 
 
'#################################################
' Gestion Evenements Enfants -- Fields
'#################################################
 
 
Private Function GestionMoveCombo(Optional MAJBoxList As Boolean) As Boolean
Dim lngTMP As Long, tmpText As String, iRec As Integer, tmpList As String
 
    'On vérifie qu'un controle a été attribué à l'action Move-LstB
     If LinkerByShortAction("Move-FIndex").IsLinked Then
         'On mémorise le texte
         tmpText = LinkerByShortAction("Move-FIndex").Value
 
         'On regarde si une demande de mise à jour du contenu de la liste est présente
         If MAJBoxList Then
             'On regarde si le controle correspond à un type List
             Select Case LCase(LinkerByShortAction("Move-FIndex").TypeCtrl)
                 Case "listbox", "combobox"
                     'On crée la liste des enregistrement dispo
                     For iRec = 1 To pDataFields.RowCount
                         If tmpList <> "" Then tmpList = tmpList & ","
                         tmpList = tmpList & iRec
                     Next
                     'On met à jour
                      LinkerByShortAction("Move-FIndex").LinkedControl.List = tmpList 'Note :  il faudra peut être adapter vers un tableau style Range
             End Select
             'On remet le text en place si possible
             LinkerByShortAction("Move-FIndex").Value = tmpText
         End If
 
         If IsNumeric(tmpText) Then
             'On récupère la valeur numérique contenue dans le listbox
             lngTMP = CLng(tmpText)
             'On vérifie que l'index proposé est dans la plage
             GestionMoveCombo = (lngTMP > 1) And (lngTMP <=  pDataFields.RowCount) And (lngTMP <> pDataFields.ActiveRow.Index)
         End If
     End If
     If LinkerByShortAction("Move-Cmd").IsLinked Then LinkerByShortAction("Move-Cmd").Enabled = GestionMoveCombo
 
End Function
 
Private Sub GestionEtat_Ctrl(Optional anIndex As Long)
Dim AtLeastOne As Boolean, boolTMP As Boolean, lngTMP As Long
Dim UsedIndex As Long
 
    UsedIndex = IIf(anIndex = 0, pDataFields.ActiveRowIndex, anIndex)
    'On regarde si il y a au moins 1 enregistrement
    AtLeastOne = pDataFields.RowCount <> 0
    'If LinkerByShortAction("ShowIndex").IsLinked Then LinkerByShortAction("ShowIndex").Value = UsedIndex
    'On regarde si les actions de déplacement sont possibles
    If LinkerByShortAction("MoveFirst").IsLinked Then LinkerByShortAction("MoveFirst").Enabled = UsedIndex > 1
    If LinkerByShortAction("MoveLast").IsLinked Then  LinkerByShortAction("MoveLast").Enabled = (UsedIndex <  pDataFields.RowCount) And AtLeastOne
    If LinkerByShortAction("MoveNext").IsLinked Then  LinkerByShortAction("MoveNext").Enabled = (UsedIndex <  pDataFields.RowCount) And AtLeastOne
    If LinkerByShortAction("MovePrevious").IsLinked Then LinkerByShortAction("MovePrevious").Enabled = UsedIndex > 1
 
End Sub
 
Private Sub pDataFields_AfterActiveRowChange(ByVal OldIndex As Long, ByVal NewIndex As Long, ByVal ErrorState As Long)
    'On active/desactive les boutons de contrôle
    GestionEtat_Ctrl
    GestionMoveCombo
 
    'On affiche le numero d'index du Row en cours
    If LinkerByShortAction("ShowIndex").IsLinked Then LinkerByShortAction("ShowIndex").Value = NewIndex
 
    pDataCtrls.SetValues pDataFields.Values
 
    'On fait suivre l'event
    RaiseEvent FieldAfterActiveRowChange(OldIndex, NewIndex, ErrorState)
End Sub
 
Private Sub pDataFields_AfterGeneralUpdate(ErrorState As Long)
    'On fait suivre l'event
    RaiseEvent FieldsAfterGeneralUpdate(ErrorState)
End Sub
 
Private Sub pDataFields_AfterRowAdding(ByVal RowIndex As Long, ByVal ErrorState As Long)
    If ErrorState = 0 Then
        'On active/desactive les boutons de contrôle
        GestionEtat_Ctrl
 
        'On modifie la liste contenue dans "Move-FIndex" si c'est un listbox ou un combobox
        GestionMoveCombo True
 
        'On place les valeurs par défaut si nécessaire
        If RowIndex = pDataFields.ActiveRowIndex Then
            'Note : Pas top, si l'option de selection du nouveau Row  n'est pas présente les valeurs par défaut ne sont jamais inscrite dans  la base...
            SetCtrlDefaultValues
            pDataFields.UpdateDataField pDataCtrls.GetValues
        End If
    End If
 
    'On fait suivre l'event
    RaiseEvent FieldAfterRowAdding(RowIndex, ErrorState)
End Sub
 
Private Sub pDataFields_AfterRowDeleting(ByVal ErrorState As Long)
    'On active/desactive les boutons de contrôle
    GestionEtat_Ctrl
    GestionMoveCombo True
 
    'On fait suivre l'event
    RaiseEvent FieldAfterRowDeleting(ErrorState)
End Sub
 
 
Private Sub pDataFields_BeforeActiveRowChange(ByVal ActualIndex As Long, FuturIndex As Long, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent FieldBeforeActiveRowChange(ActualIndex, FuturIndex, Cancel)
End Sub
 
Private Sub pDataFields_BeforeGeneralUpdate(ByVal ti_NewValues As Variant, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent FieldsBeforeGeneralUpdate(ti_NewValues, Cancel)
End Sub
 
Private Sub pDataFields_BeforeRowAdding(ActiveNewAddedRow As Boolean, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent FieldBeforeRowAdding(ActiveNewAddedRow, Cancel)
End Sub
 
Private Sub pDataFields_BeforeRowDeleting(ByVal RowIndex As Long, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent FieldBeforeRowDeleting(RowIndex, Cancel)
End Sub
 
Private Sub pDataFields_DataValueUpdate(CallerField As Cls_TSToDataField, IsGlobalUpdate As Boolean, ByVal OldValue As Variant)
    'On fait suivre l'event
    RaiseEvent FieldValueUpdate(CallerField, IsGlobalUpdate, OldValue)
End Sub
 
Private Sub pDataFields_FirstRowActivate()
    'On fait suivre l'event
    RaiseEvent FieldFirstRowActivate
End Sub
 
Private Sub pDataFields_LastRowActivate()
    'On fait suivre l'event
    RaiseEvent FieldLastRowActivate
End Sub
 
Private Sub pDataFields_TestingUpdateValue(CallerField As Cls_TSToDataField, ByVal Value As String, RejectValue As Boolean)
    'On fait suivre l'event
    RaiseEvent FieldTestingUpdateValue(CallerField, Value, RejectValue)
End Sub
 
 
'#################################################
' Gestion Evenements Enfants -- Linker-Ctrl
'#################################################
 
'Note : Type perso impossible en public
Private Function TestOptions(anOption As en_OptionDataMaster) As Boolean
    TestOptions = pOptions And anOption
End Function
 
Private Sub pDataCtrls_NeedAlias(ByVal CallerLinker As Cls_TSToDataLinker, ByRef CommaListAlias As String)
    'On retourne les alias dispo
    CommaListAlias = GetLinkerRawInfo(LkInfo_Alias, pti_TabCtrls, CallerLinker.Name)
 
    'On fait suivre l'event
    RaiseEvent CtrlNeedAlias(CallerLinker, CommaListAlias)
End Sub
 
Private Sub pDataCtrls_LinkerChange(CallerLinker As Cls_TSToDataLinker)
    RefreshBackColor CallerLinker
End Sub
 
 
Private Sub pDataCtrls_NeedConvertToBoolean(CallerLinker As Cls_TSToDataLinker, aValue As Variant, NewValue As Variant)
Dim Retour As Variant
    'On déduit la valeur
    Retour = SayIsTrueFalseNull(aValue, CallerLinker.Name, pti_TabCtrls)
 
    'Todo : Ajouter un event
    NewValue = Retour
 
    'On fait suivre l'event
    RaiseEvent CtrlNeedConvertToBoolean(CallerLinker, aValue, NewValue)
End Sub
 
Private Sub pDataCtrls_AddInLinkerList(CallerLinker As Cls_TSToDataLinker, ByVal NewValue As String, Cancel As Boolean)
    'Une valeur est sur le point d'être ajoutée
    'On vérifie que les options nous y autorise
    Cancel = Not (pOptions And opt_AddingInListIfDataValueAbsent)
 
    'On fait suivre l'event
    RaiseEvent CtrlAddInLinkerList(CallerLinker, NewValue, Cancel)
End Sub
 
Private Sub pDataCtrls_ValueNotInList(CallerLinker As Cls_TSToDataLinker, ByVal UnknowValue As String)
    'On fait suivre l'event
    RaiseEvent CtrlValueNotInList(CallerLinker, UnknowValue)
End Sub
 
Private Sub pDataCtrls_AfterUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByVal ErrorState As Long)
    RefreshBackColor CallerLinker
 
    'On fait suivre l'event
    RaiseEvent CtrlAfterUpdateValue(CallerLinker, UpdateGlobal, ErrorState)
End Sub
 
Private Sub pDataCtrls_BeforeUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent CtrlBeforeUpdateValue(CallerLinker, UpdateGlobal, Cancel)
End Sub
 
 
Private Sub pDataCtrls_AfterUpdateValues(ByVal ErrorState As Long)
    'On fait suivre l'event
    RaiseEvent CtrlAfterUpdateValues(ErrorState)
End Sub
 
Private Sub pDataCtrls_BeforeUpdateValues(ByVal it_Values As Variant, ByVal ClearMissing As Boolean, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent CtrlBeforeUpdateValues(it_Values, ClearMissing, Cancel)
End Sub
 
Private Sub pDataCtrls_NewLinkerAdded(NewLinker As Cls_TSToDataLinker)
    'On fait suivre l'event
    RaiseEvent CtrlNewLinkerAdded(NewLinker)
 
    'On met à jour
End Sub
 
 
 
'#################################################
' Gestion Evenements Enfants -- Linker-Action
'#################################################
 
 
Private Sub pDataActions_NewLinkerAdded(NewLinker As Cls_TSToDataLinker)
    'On fait suivre l'event
    RaiseEvent ActionNewLinkerAdded(NewLinker)
End Sub
 
Private Sub pDataActions_NeedAlias(ByVal CallerLinker As Cls_TSToDataLinker, CommaListAlias As String)
    'On retourne les alias dispo
    CommaListAlias = GetLinkerRawInfo(LkInfo_Alias, pti_TabActions, CallerLinker.Name)
    'On fait suivre l'event
    RaiseEvent ActionNeedAlias(CallerLinker, CommaListAlias)
 
End Sub
 
Private Sub pDataActions_LinkerChange(CallerLinker As Cls_TSToDataLinker) ', LinkName As String
'TOdo : Mettre des Public Sub pour chaque Action pour les rendre accessible à l'utilisateur à partir du DataMaster ??
Dim i As Integer
 
    'On traite la demande d'action
   Select Case FindShortName(CallerLinker.Name)
        Case "ShowIndex"
            'Normalement pas d'action possible sur cette action
        Case "MoveFirst"
            MoveToFirstRow
        Case "MoveLast"
            MoveToLastRow
        Case "MoveNext"
            MoveToNextRow
        Case "MovePrevious"
            MoveToPreviousRow
        Case "Move-Cmd"
            MoveToRow CLng(LinkerByShortAction("Move-FIndex").Value)
        Case "Move-FIndex"
            GestionMoveCombo
        Case "AddRow"
            AddRow 'Todo : Ajouter l'option Active new row
        Case "DelActiveRow"
            DeleteRow
        Case "MAJData"
            'On transmet les valeurs contenues dans les contrôles de saisie
            UpdateDataField GetCtrlValues
        Case "MAJCtrl"
            SetCtrlsValues GetDataValues
        Case "HSMAJ"
            'Création de la bascule
            DataReadOnly = (CallerLinker.Value = GetLinkerRawInfo(LkInfo_Captionactif, pti_TabActions, CallerLinker.Name))
        Case "ClearCtrl"
            ClearCtrlsContents
        Case "DefValCtrl"
            SetCtrlDefaultValues
        Case "Opt-AddAbs"
            Option_AddingInListIfDataValueAbsent = CallerLinker.Value
        Case "Opt-ColorAbs" ',"
            Option_ColorControlIfDataValueAbsent = CallerLinker.Value
            RefreshAllCtrlBackcolor
        Case "Opt-ColorNeeded"
            Option_ColorControlIfNeededIsEmpty = CallerLinker.Value
            RefreshAllCtrlBackcolor
        Case "Opt-MsgError"
            Option_ManageErrorMessage = CallerLinker.Value
        Case "Opt-MoveNewRow"
            Option_ActiveNewRow = CallerLinker.Value
        Case Else
            'Gestion de linker manuel -> Event
            RaiseEvent ActionManagingEvent(CallerLinker, CallerLinker.Name)
    End Select
End Sub
 
Private Sub pDataActions_NeedConvertToBoolean(CallerLinker As  Cls_TSToDataLinker, ByVal aValue As Variant, ByRef NewValue As Variant)
Dim Retour As Variant
    'On déduit la valeur
    Retour = SayIsTrueFalseNull(aValue, CallerLinker.Name, pti_TabActions)
    NewValue = Retour
 
    'On fait suivre l'event
    RaiseEvent ActionNeedConvertToBoolean(CallerLinker, aValue, NewValue)
End Sub
 
Private Sub pDataActions_AddInLinkerList(CallerLinker As Cls_TSToDataLinker, ByVal NewValue As String, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent ActionAddInLinkerList(CallerLinker, NewValue, Cancel)
End Sub
 
Private Sub pDataActions_AfterUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, ByVal ErrorState As Long)
    'On fait suivre l'event
    RaiseEvent ActionAfterUpdateValue(CallerLinker, UpdateGlobal, ErrorState)
End Sub
 
Private Sub pDataActions_AfterUpdateValues(ByVal ErrorState As Long)
    'On fait suivre l'event
    RaiseEvent ActionAfterUpdateValues(ErrorState)
End Sub
 
Private Sub pDataActions_BeforeUpdateValue(CallerLinker As Cls_TSToDataLinker, UpdateGlobal As Boolean, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent ActionBeforeUpdateValue(CallerLinker, UpdateGlobal, Cancel)
End Sub
 
Private Sub pDataActions_BeforeUpdateValues(ByVal it_Values As Variant, ByVal ClearMissing As Boolean, Cancel As Boolean)
    'On fait suivre l'event
    RaiseEvent ActionBeforeUpdateValues(it_Values, ClearMissing, Cancel)
End Sub
 
Private Sub pDataActions_ValueNotInList(CallerLinker As Cls_TSToDataLinker, ByVal UnknowValue As String)
    'On fait suivre l'event
    RaiseEvent ActionValueNotInList(CallerLinker, UnknowValue)
End Sub

**Qwazerty** · 27/01/2020, 17h45

Salut

Mise à Jour, il y avait des bugs présents dans le fichier joint... (je ne remet pas le code de tous les modules, j'aurais des modifications à y faire et il ne semble pas y avoir foule de gens intéressés

)

++
Qwaz

**iliyes** · 09/01/2022, 16h41

BOnjour Qwazerty
Y a t il un moyen d'avoir le fichier complet???
merci d'avance

**Qwazerty** · 09/01/2022, 19h52

Bonjour

Merci de l'intérêt porté à ce travail (que je n'ai malheureusement pas eu le temps de continuer).
Tout les codes sont disponibles dans le fichier fourni dans le dernier message

++
Qwaz

**curt** · 23/02/2022, 15h25

Bonjour Qwazerty,

voilà un sujet dans mon actualité et qui répond parfaitement bien à ce que je compte mettre en place.
Un grand merci

pour ce partage.

**Qwazerty** · 24/02/2022, 00h16

Salut Curt

Je suis content que ça puisse servir

N'hésite pas à faire un retour s'il y a des modifications à apporter... Il me faudra un peu de temps pour m'y replonger et recomprendre ce que j'avais fait parcontre

++
Qwaz

Invité · 08/01/2023, 05h54

Salut Qwazerty

Joli travail

**Qwazerty** · 08/01/2023, 19h17

Salut BrunoM45

Merci

.
N'hésite pas à faire un retour pour me dire ce qui t'a était utile. Comme ça, si un jour je me remet dessus, je sais quoi priorisé en fonction de ce que les gens utilisent

++
Qwaz

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

Contribuez

Discussions similaires

Partager

Partager