Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

  1. #1
    Expert éminent
    Excel | Tableau Structuré | Base de données | UserForm
    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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  2. #2
    Expert éminent
    Exemple d'utilisation
    Un exemple d'utilisation (Radio Boutons non fonctionnels)


    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


    4 options sont disponibles
    1. 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.

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

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

    4. 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 )

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  3. #3
    Expert éminent
    Concernant le tableau faisant le lien entre champs et contrôles (celui de droite donc)


    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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  4. #4
    Expert éminent
    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



    ++
    Qwaz

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  5. #5
    Expert éminent
    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


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

    ++
    Qwaz

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  6. #6
    Expert éminent
    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 <img src="images/smilies/icon_wink.gif" border="0" alt="" title=";)" class="inlineimg" />
    '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 <img src="images/smilies/icon_wink.gif" border="0" alt="" title=";)" class="inlineimg" />
    '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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  7. #7
    Expert éminent
    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+)\|(?<img src="images/smilies/icon_sad.gif" border="0" alt="" title=":(" class="inlineimg" />Vrai|Faux)){0,1}\|(?<img src="images/smilies/icon_sad.gif" border="0" alt="" title=":(" class="inlineimg" />.[^|;]+)){0,1}\|(?<img src="images/smilies/icon_sad.gif" border="0" alt="" title=":(" class="inlineimg" />.[^|]+)){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}\](.+)\|(?<img src="images/smilies/icon_sad.gif" border="0" alt="" title=":(" class="inlineimg" />Vrai|Faux)){0,1}\|(?<img src="images/smilies/icon_sad.gif" border="0" alt="" title=":(" class="inlineimg" />.+)){0,1}\|(?<img src="images/smilies/icon_sad.gif" border="0" alt="" title=":(" class="inlineimg" />.[^|]+)){0,1}\|(?<img src="images/smilies/icon_sad.gif" border="0" alt="" title=":(" class="inlineimg" />.[^|]+)){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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  8. #8
    Expert éminent
    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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

###raw>template_hook.ano_emploi###