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:

---

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:

---

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:

---

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:

---

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

Un exemple d'utilisation (Radio Boutons non fonctionnels)
Pièce jointe 526746

Avec le code du UserForm

Code:

---

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
Pièce jointe 526715

---

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 ;))
Pièce jointe 526713

Concernant le tableau faisant le lien entre champs et contrôles (celui de droite donc)
Pièce jointe 526719

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:

---

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

Salut

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

Pièce jointe 528800

++
Qwaz

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.
:arrow:Cls_OptBoutGroupe
:arrow: 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.

:arrow:Cls_TSToDataFields
:arrow: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.

:arrow:Cls_TSToDataLinkers
:arrow: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

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

---

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
Pièce jointe 532907

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

++
Qwaz

:arrow:Cls_TSToDataFields

Code:

---

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

---

:arrow:Cls_TSToDataField

Code:

---

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

---

:arrow:Cls_TSToDataLinkers

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426

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

---

:arrow:Cls_TSToDataLinker

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476

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

---

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

++
Qwaz