Discussion :

[pijaku]

Bonjour à toutes et tous,

Cette contribution fait suite à cette discussion sur le forum macros et VBA Excel.
Le choix d'implémenter plusieurs modules de classe pour contrôler la saisie des textbox n'est bien évidemment ici qu'un cas d'étude permettant de réaliser une Interface en VBA.
Loin de moi l'idée de dire que ce modèle est la solution pour vos textbox d'userform, il s'agit simplement d'un exemple de construction.

Les sources sont toutes citées en commentaires, dans le code du module standard.

Je vous livre les codes tels quels car, n'étant pas bon rédacteur, je ne saurais vous délivrer un tutoriel complet explicatif.
Sachez néanmoins que pour générer les événement Exit, Enter, BeforeUpdate et AfterUpdate, j'utilise ici l'API ConnectToConnectionPoint de la Library "shlwapi".
Celle-ci est utilisée dans le module de Classe (module d'interface) iTextBox, grâce à sa méthode ConnectEvent.
L'explication a été donnée dans la discussion relative à cette contribution (lien plus haut).

Je vous ai mis, dans ces codes de démo, 5 exemples de classe de textbox. Cela peut sembler beaucoup, mais ce sera plus agréable pour vos tests

Voici les codes donc :
l'UserForm :
Insérez un UserForm dans votre classeur, mais n'y placez aucun contrôle. La procédure Creation_Dynamique_Des_Controles s'en charge pour vous. Sympa non?

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
Option Explicit
 
    Dim CollCtrl As New myCollection
 
    Private Sub UserForm_Initialize()
        Call Creation_Dynamique_Des_Controles
    'ajout à la collection :
        'la méthode Add a besoin de 4 paramètres :
            'newClass As iTextbox   => Une instance de l'Interface via la classe choisie
            'Obj As Object          => Le contrôle TextBox
'AJOUT TEXTBOX
        CollCtrl.Add New cMajuscules, Me.Controls("TextBox1")
        'Pour le TextBox2 : aucune particularité
        CollCtrl.Add New cSecuSociale, Me.Controls("TextBox3")
        CollCtrl.Add New cTBDate, Me.Controls("TextBox4")
        CollCtrl.Add New cTBHeure, Me.Controls("TextBox5")
        CollCtrl.Add New cMajuscules, Me.Controls("TextBox6")
        CollCtrl.Add New cNumerique, Me.Controls("TextBox7")
        'Pour le TextBox8 : aucune particularité
        CollCtrl.Add New cNumerique, Me.Controls("TextBox9")
        CollCtrl.Add New cMajuscules, Me.Controls("TextBox10")
        CollCtrl.Add New cNumerique, Me.Controls("TextBox11")
        CollCtrl.Add New cNumerique, Me.Controls("TextBox12")
        CollCtrl.Add New cNumerique, Me.Controls("TextBox13")
        CollCtrl.Add New cNumerique, Me.Controls("TextBox14")
'AJOUT "CONTAINERS"
        CollCtrl.Add New myContenairs, Me.Controls("Frame1")
        CollCtrl.Add New myContenairs, Me.Controls("Frame2")
        CollCtrl.Add New myContenairs, Me.Controls("Frame3")
        CollCtrl.Add New myContenairs, Me.Controls("Frame4")
        CollCtrl.Add New myContenairs, Me.Controls("MultiPage1").Page1
        CollCtrl.Add New myContenairs, Me.Controls("MultiPage1").Page2
        CollCtrl.Add New myContenairs, Me.Controls("MultiPage1")
    End Sub
 
    Private Sub UserForm_Terminate()
        Dim i As Long
        For i = 1 To CollCtrl.Count
            CollCtrl.item(i).Clear
        Next i
        Set CollCtrl = Nothing
    End Sub
 
    Private Sub Creation_Dynamique_Des_Controles()
        Dim Ct As Control, Frm As Frame, Frm2 As Frame, Frm3 As Frame, Multi As MultiPage
 
        Me.Move Me.Left, Me.Top, 470, 540
        Set Ct = Me.Controls.Add("forms.Label.1", "Lab1", True)
        Ct.Move 10, 10, 40, 20
        Ct.Caption = "NOM"
        Set Ct = Me.Controls.Add("forms.TextBox.1", "TextBox1", True)
        Ct.Move 50, 10, 100, 20
        Set Ct = Me.Controls.Add("forms.Label.1", "Lab2", True)
        Ct.Move 10, 30, 40, 20
        Ct.Caption = "Prénom"
        Set Ct = Me.Controls.Add("forms.TextBox.1", "TextBox2", True)
        Ct.Move 50, 30, 100, 20
        Set Ct = Me.Controls.Add("forms.Label.1", "Lab3", True)
        Ct.Move 10, 50, 40, 20
        Ct.Caption = "Sécurité Soc"
        Set Ct = Me.Controls.Add("forms.TextBox.1", "TextBox3", True)
        Ct.Move 50, 50, 100, 20
        Set Frm = Me.Controls.Add("forms.Frame.1", "Frame1", True)
        With Frm
            .Move 160, 10, 200, 100
            .Caption = "Etat civil"
            Set Ct = .Controls.Add("forms.Label.1", "Lab4", True)
            Ct.Move 10, 10, 40, 20
            Ct.Caption = "Date Naiss"
            Set Ct = .Controls.Add("forms.TextBox.1", "TextBox4", True)
            Ct.Move 50, 10, 70, 20
            Set Ct = .Controls.Add("forms.Label.1", "Lab5", True)
            Ct.Move 10, 30, 40, 20
            Ct.Caption = "Heure"
            Set Ct = .Controls.Add("forms.TextBox.1", "TextBox5", True)
            Ct.Move 50, 30, 70, 20
            Set Ct = .Controls.Add("forms.Label.1", "Lab6", True)
            Ct.Move 10, 50, 40, 20
            Ct.Caption = "VILLE"
            Set Ct = .Controls.Add("forms.TextBox.1", "TextBox6", True)
            Ct.Move 50, 50, 100, 20
        End With
        Set Ct = Me.Controls.Add("forms.CommandButton.1", "Bouton1", True)
        Ct.Move 370, 10, 80, 20
        Ct.Caption = "BOUTONS POUR"
        Set Ct = Me.Controls.Add("forms.CommandButton.1", "Bouton2", True)
        Ct.Move 370, 35, 80, 20
        Ct.Caption = "TESTER SORTIE"
        Set Ct = Me.Controls.Add("forms.CommandButton.1", "Bouton3", True)
        Ct.Move 370, 60, 80, 20
        Ct.Caption = "PAR CLIC"
        Set Multi = Me.Controls.Add("forms.Multipage.1", "Multipage1", True)
        With Multi
            .Move 10, 120, 400, 150
            With .Pages(0)
                .Caption = "ADRESSE 1"
                Set Ct = .Controls.Add("forms.Label.1", "Lab7", True)
                Ct.Move 10, 10, 40, 20
                Ct.Caption = "NUMERO"
                Set Ct = .Controls.Add("forms.TextBox.1", "TextBox7", True)
                Ct.Move 50, 10, 30, 20
                Set Ct = .Controls.Add("forms.Label.1", "Lab8", True)
                Ct.Move 10, 30, 40, 20
                Ct.Caption = "RUE"
                Set Ct = .Controls.Add("forms.TextBox.1", "TextBox8", True)
                Ct.Move 50, 30, 300, 60
            End With
            With .Pages(1)
                .Caption = "ADRESSE 2"
                Set Ct = .Controls.Add("forms.Label.1", "Lab9", True)
                Ct.Move 10, 10, 40, 20
                Ct.Caption = "CODE POSTAL"
                Set Ct = .Controls.Add("forms.TextBox.1", "TextBox9", True)
                Ct.Move 50, 10, 50, 20
                Set Ct = .Controls.Add("forms.Label.1", "Lab10", True)
                Ct.Move 10, 30, 40, 20
                Ct.Caption = "VILLE"
                Set Ct = .Controls.Add("forms.TextBox.1", "TextBox10", True)
                Ct.Move 50, 30, 150, 20
            End With
        End With
        Set Frm = Me.Controls.Add("forms.Frame.1", "Frame2", True)
        With Frm
            .Caption = "Tout numérique"
            .Move 35, 300, 400, 200
            Set Ct = .Controls.Add("forms.TextBox.1", "TextBox11", True)
            Ct.Move 10, 10, 240, 20
            Set Frm2 = .Controls.Add("forms.Frame.1", "Frame3", True)
        End With
        With Frm2
            .Move 10, 35, 370, 140
            Set Ct = .Controls.Add("forms.TextBox.1", "TextBox12", True)
            Ct.Move 10, 10, 240, 20
            Set Frm3 = .Controls.Add("forms.Frame.1", "Frame4", True)
        End With
        With Frm3
            .Move 10, 35, 350, 100
            Set Ct = .Controls.Add("forms.TextBox.1", "TextBox13", True)
            Ct.Move 10, 10, 100, 20
            Set Ct = .Controls.Add("forms.TextBox.1", "TextBox14", True)
            Ct.Move 10, 30, 100, 20
        End With
        Set Frm = Nothing
        Set Frm2 = Nothing
        Set Frm3 = Nothing
        Set Ct = Nothing
        Set Multi = Nothing
    End Sub

L'Interface :
Ici, il y a une petite manipulation à faire :

1. Copiez-collez ce code dans votre bloc note (ou éditeur de texte favori),
2. "décommentez" les lignes contenant les Attribute VB_UserMemId (procédures Entree, Sortie, AvantMiseAjour, ApresMiseAjour)
3. Enregistrez votre fichier sous le nom iTextbox.cls
4. Importez le dans VBE (clic droit dans la fenêtre VBA-Project / Importer un fichier...)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "iTextbox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
 
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
 
    #If VBA7 And Win64 Then
        Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" _
                 (ByVal punk As stdole.IUnknown, _
                 ByRef riidEvent As GUID, _
                 ByVal fConnect As Long, _
                 ByVal punkTarget As stdole.IUnknown, _
                 ByRef pdwCookie As Long, _
                 Optional ByVal ppcpOut As LongPtr) As Long
    #Else
        Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" _
                 (ByVal punk As stdole.IUnknown, _
                 ByRef riidEvent As GUID, _
                 ByVal fConnect As Long, _
                 ByVal punkTarget As stdole.IUnknown, _
                 ByRef pdwCookie As Long, _
                 Optional ByVal ppcpOut As Long) As Long
    #End If
 
    Private iCook As Long
    Private iObjet As Object
    Private iNom As String
    Private iFocus As Boolean
    Private iIndex As Long
 
    Private Sub ConnectEvent(ByVal Connect As Boolean)
    Dim cGuid As GUID
        With cGuid
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        ConnectToConnectionPoint Me, cGuid, Connect, iObjet, iCook, 0&
    End Sub
 
    Public Sub item(NewCtrl As Object, Ind As Long)
        Set iObjet = NewCtrl
        iIndex = Ind
        iNom = NewCtrl.Name
        Call ConnectEvent(True)
    End Sub
 
    Public Property Let Focus(booF As Boolean)
        iFocus = booF
    End Property
 
    Public Property Get Focus() As Boolean
        Focus = iFocus
    End Property
 
    Public Property Get Nom() As String
        Nom = iNom
    End Property
 
    Public Sub Clear()
        If (iCook <> 0) Then Call ConnectEvent(False)
        Set iObjet = Nothing
    End Sub
 
    ' Liste des Attribute VB_UserMemId
    '     Enter              &H80018202 = -2147384830
    '     Exit               &H80018203 = -2147384829
    '     BeforeUpdate       &H80018201 = -2147384831
    '     AfterUpdate        &H80018200 = -2147384832
 
    Public Sub Entree()
'Attribute Entree.VB_UserMemId = -2147384830
 
        Focus = True
        CallByName tbColl.item(iIndex), "Entree", VbMethod
    End Sub
 
    Public Sub Sortie(ByVal Cancel As MSForms.ReturnBoolean)
'Attribute Sortie.VB_UserMemId = -2147384829
 
        CallByName tbColl.item(iIndex), "Sortie", VbMethod, Cancel
        Focus = CBool(Cancel)
    End Sub
 
    Public Sub AvantMiseAjour(ByVal Cancel As MSForms.ReturnBoolean)
'Attribute AvantMiseAjour.VB_UserMemId = -2147384831
 
        CallByName tbColl.item(iIndex), "AvantMiseAjour", VbMethod, Cancel
    End Sub
 
    Public Sub ApresMiseAjour()
'Attribute ApresMiseAjour.VB_UserMemId = -2147384832
 
        CallByName tbColl.item(iIndex), "ApresMiseAjour", VbMethod
    End Sub

A noter : Vous voyez ici qu'il est fort possible de placer du code dans les méthodes de l'interface...

La collection :
gérée dans un module de classe nommé myCollection (oui, oui, je sais pas original...)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Explicit
 
    Private Sub Class_Initialize()
        Set tbColl = New Collection
    End Sub
 
    Public Sub Class_Terminate()
        Set tbColl = Nothing
    End Sub
 
    Public Sub Add(ByVal newClass As iTextbox, ByVal Obj As Object)
        'la méthode Add a besoin de 2 paramètres :
            'newClass As iTextbox   => Une instance de l'Interface via la classe choisie
            'Obj As Object          => Le contrôle lui-même
        tbColl.Add newClass
        newClass.item Obj, tbColl.Count
    End Sub
 
    Public Sub Remove(Index As Variant)
        tbColl.Remove (Index)
    End Sub
 
    Public Property Get item(Index As Long) As iTextbox
        Set item = tbColl.item(Index)
    End Property
 
    Public Property Get Count() As Long
        Count = tbColl.Count
    End Property

Cette classe "alimente" un collection nommée tbColl, déclarée dans un module standard en portée Public.

Le module standard
Nommé comme vous le souhaitez...
Profitez en pour consulter les sources si vous en exprimez l'envie...

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Option Explicit
 
'Sources :
    'Code de myCollection.cls         
    'Code de la variable Parent As ITextBox :
        'http://www.developpez.net/forums/d636773-2/logiciels/microsoft-office/general-vba/polymorphisme-implementation/#post4801023
 
    'Interface :
        'http://www.cpearson.com/Excel/Implements.aspx
        'http://www.developpez.net/forums/d636773-2/logiciels/microsoft-office/general-vba/polymorphisme-implementation/
 
    'Implementation of the event handling by API: ConnectToConnectionPoint :
        'http://www.h3.dion.ne.jp/~sakatsu/Breakthrough_P-Ctrl_Arrays_Eng_ref.htm#C2CP
 
    'Corrections :
        'http://www.developpez.net/forums/d1581864/logiciels/microsoft-office/excel/macros-vba-excel/vba-gestion-evenements-interface-implementee-plusieurs-classes-textbox/
 
    'Textbox numérique :
        'http://didier-gonard.developpez.com/tutoriels/office/excel/obliger-saisie-numerique-dans-texbox/#LV-F-1
 
    'variable publique collection des contrôles (cf module de classe myCollection)
    Public tbColl As Collection
 
    'constantes de couleurs des textbox
    'si pas de changement de couleur, régler COULEUR_VISITEE = COULEUR_INITIALE
    Public Const COULEUR_INITIALE As Long = &H80000005
    Public Const COULEUR_VISITEE As Long = &H80000003
 
    'Constantes séparateurs
    Public Const SEP_DATE As String = "/"
    Public Const SEP_TIME As String = ":"

La classe cMajuscules
Permet uniquement la saisie de caractères alphabétiques et du trait d'union. Pas d'espace, possibilité de supprimer.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
'------------------------------------------------------ Code commun à toutes les classes de TextBox
Option Explicit
 
Implements iTextbox
 
    Private Parent As iTextbox
    Private WithEvents cTBx As MSForms.TextBox
 
    'création du "lien" avec l'Interface
    Private Sub Class_Initialize()
        Set Parent = New iTextbox
    End Sub
 
    'propriétés de l'Interface
    Public Sub iTextBox_Item(NewCtrl As Object, i As Long)
        Parent.item NewCtrl, i
        Set cTBx = NewCtrl
    End Sub
    Public Property Let iTextBox_Focus(booF As Boolean)
        Parent.Focus = booF
    End Property
    Public Property Get iTextBox_Focus() As Boolean
        iTextBox_Focus = Parent.Focus
    End Property
    Public Property Get iTextBox_Nom() As String
        iTextBox_Nom = Parent.Nom
    End Property
 
    'Méthode publique de l'Interface
    Public Sub iTextBox_Clear()
        Call Parent.Clear
    End Sub
 
    'événements supplémentaires, non gérés dynamiquement par les textbox, mais gérés ici par l'interface
    Public Sub iTextBox_Entree()
        'saisir ici le code à déclencher dans "TextBox_Enter"
        cTBx.BackColor = COULEUR_VISITEE
    End Sub
    Public Sub iTextBox_Sortie(ByVal Cancel As MSForms.ReturnBoolean)
        If Len(cTBx.Text) < 1 Then Cancel = True: Exit Sub
        cTBx.BackColor = COULEUR_INITIALE
    End Sub
    Public Sub iTextBox_AvantMiseAjour(ByVal Cancel As MSForms.ReturnBoolean)
 
    End Sub
    Public Sub iTextBox_ApresMiseAjour()
 
    End Sub
'------------------------------------------------------ Fin du code commun à toutes les classes de TextBox
 
 
'------------------------------------------------------ Evénements propres à la classe cMajuscules
    Private Sub cTBx_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
        Select Case KeyAscii
            Case 32 'espace
                KeyAscii = 0
            Case 45  'trait d'union
                If Len(cTBx.Text) = 0 Then KeyAscii = 0
            Case 65 To 90 'majuscules
            Case 97 To 122 'minuscules
                KeyAscii = KeyAscii - 32
            Case Else
                KeyAscii = 0
        End Select
    End Sub

A Noter : ici et dans les autres modules de classe, la ligne Implements iTextbox.

Classe cNumerique :
Merci à Didier Gonard pour son tutoriel (cité dans les sources)
Ne permet que la saisie de numériques selon le tutoriel cité.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
'------------------------------------------------------ Code commun à toutes les classes de TextBox
Option Explicit
 
Implements iTextbox
 
    Private Parent As iTextbox
    Private WithEvents cTBx As MSForms.TextBox
 
    'création du "lien" avec l'Interface
    Private Sub Class_Initialize()
        Set Parent = New iTextbox
    End Sub
 
    'propriétés de l'Interface
    Public Sub iTextBox_Item(NewCtrl As Object, i As Long)
        Parent.item NewCtrl, i
        Set cTBx = NewCtrl
    End Sub
    Public Property Let iTextBox_Focus(booF As Boolean)
        Parent.Focus = booF
    End Property
    Public Property Get iTextBox_Focus() As Boolean
        iTextBox_Focus = Parent.Focus
    End Property
    Public Property Get iTextBox_Nom() As String
        iTextBox_Nom = Parent.Nom
    End Property
 
    'Méthode publique de l'Interface
    Public Sub iTextBox_Clear()
        Call Parent.Clear
    End Sub
 
    'événements supplémentaires, non gérés dynamiquement par les textbox, mais gérés ici par l'interface
    Public Sub iTextBox_Entree()
        'saisir ici le code à déclencher dans "TextBox_Enter"
        cTBx.BackColor = COULEUR_VISITEE
    End Sub
    Public Sub iTextBox_Sortie(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_Exit"
        If cTBx.Value = "" Then Cancel = True: Exit Sub
        cTBx.BackColor = COULEUR_INITIALE
    End Sub
    Public Sub iTextBox_AvantMiseAjour(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_BeforeUpdate"
        Dim strpass As String
        strpass = cTBx.Value
        If ChainePasOK(strpass) = True Then Cancel = True
    End Sub
    Public Sub iTextBox_ApresMiseAjour()
        'saisir ici le code à déclencher dans "TextBox_AfterUpdate"
 
    End Sub
'------------------------------------------------------ Fin du code commun à toutes les classes de TextBox
 
 
'------------------------------------------------------ Evénements propres à la classe cNumerique
    Private Sub cTBx_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
       If InStr("1234567890,-", Chr(KeyAscii)) = 0 Or cTBx.SelStart > 0 And Chr(KeyAscii) = "-" _
         Or InStr(cTBx.Value, ",") <> 0 And Chr(KeyAscii) = "," Then
          KeyAscii = 0
       End If
    End Sub
 
    Private Function ChainePasOK(strpass As String) As Boolean
       If strpass = "" Then Exit Function
       If Len(Replace(strpass, ".", "")) <> Len(strpass) Then ChainePasOK = True: Exit Function
       If Len(strpass) = 1 And InStr("1234567890", strpass) = 0 Then ChainePasOK = True: Exit Function
       strpass = Replace(strpass, ",", ".")
       If Len(CStr(Val(strpass))) <> Len(strpass) Then ChainePasOK = True
    End Function

La Classe cSecuSociale :
Code de sécurité sociale : 15 chiffres, ni plus, ni moins.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
'------------------------------------------------------ Code commun à toutes les classes de TextBox
Option Explicit
 
Implements iTextbox
 
    Private Parent As iTextbox
    Private WithEvents cTBx As MSForms.TextBox
 
    'création du "lien" avec l'Interface
    Private Sub Class_Initialize()
        Set Parent = New iTextbox
    End Sub
 
    'propriétés de l'Interface
    Public Sub iTextBox_Item(NewCtrl As Object, i As Long)
        Parent.item NewCtrl, i
        Set cTBx = NewCtrl
    End Sub
    Public Property Let iTextBox_Focus(booF As Boolean)
        Parent.Focus = booF
    End Property
    Public Property Get iTextBox_Focus() As Boolean
        iTextBox_Focus = Parent.Focus
    End Property
    Public Property Get iTextBox_Nom() As String
        iTextBox_Nom = Parent.Nom
    End Property
 
    'Méthode publique de l'Interface
    Public Sub iTextBox_Clear()
        Call Parent.Clear
    End Sub
 
    'événements supplémentaires, non gérés dynamiquement par les textbox, mais gérés ici par l'interface
    Public Sub iTextBox_Entree()
        'saisir ici le code à déclencher dans "TextBox_Enter"
        cTBx.BackColor = COULEUR_VISITEE
    End Sub
    Public Sub iTextBox_Sortie(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_Exit"
        If Len(cTBx.Text) < 15 Then Cancel = True: Exit Sub
        cTBx.BackColor = COULEUR_INITIALE
    End Sub
    Public Sub iTextBox_AvantMiseAjour(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_BeforeUpdate"
    End Sub
    Public Sub iTextBox_ApresMiseAjour()
        'saisir ici le code à déclencher dans "TextBox_AfterUpdate"
    End Sub
'------------------------------------------------------ Fin du code commun à toutes les classes de TextBox
 
 
'------------------------------------------------------ Evénements propres à la classe cSecuSociale
    Private Sub cTBx_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
        Select Case KeyCode
            Case 96 To 105  'chiffres pavé numérique
                If Shift = 1 Then KeyCode = 0
                If Len(cTBx.Text) = 15 Then KeyCode = 0
            Case 48 To 57   'chiffre touches clavier alphanumérique
                If Shift = 0 Then KeyCode = 0
                If Len(cTBx.Text) = 15 Then KeyCode = 0
            Case 8, 9, 16, 46  'touches retour arrière, TAB, Shift, Suppr
                'action à voir
            Case Else
                KeyCode = 0
        End Select
    End Sub

La classe cTBDate :
Merci à Jacques pour son code de contrôle de saisie de date. Pour ses fonctionnalités, se reporter aux sources...

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
'------------------------------------------------------ Code commun à toutes les classes de TextBox
Option Explicit
 
Implements iTextbox
 
    Private Parent As iTextbox
    Private WithEvents cTBx As MSForms.TextBox
 
    'création du "lien" avec l'Interface
    Private Sub Class_Initialize()
        Set Parent = New iTextbox
    End Sub
 
    'propriétés de l'Interface
    Public Sub iTextBox_Item(NewCtrl As Object, i As Long)
        Parent.item NewCtrl, i
        Set cTBx = NewCtrl
    End Sub
    Public Property Let iTextBox_Focus(booF As Boolean)
        Parent.Focus = booF
    End Property
    Public Property Get iTextBox_Focus() As Boolean
        iTextBox_Focus = Parent.Focus
    End Property
    Public Property Get iTextBox_Nom() As String
        iTextBox_Nom = Parent.Nom
    End Property
 
    'Méthode publique de l'Interface
    Public Sub iTextBox_Clear()
        Call Parent.Clear
    End Sub
 
    'événements supplémentaires, non gérés dynamiquement par les textbox, mais gérés ici par l'interface
    Public Sub iTextBox_Entree()
        'saisir ici le code à déclencher dans "TextBox_Enter"
        cTBx.BackColor = COULEUR_VISITEE
    End Sub
    Public Sub iTextBox_Sortie(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_Exit"
        If cTBx.Text <> "" And Len(cTBx.Text) < 10 Then
            Cancel = True
        ElseIf cTBx.Text = "" Then
            Cancel = True
        Else
            cTBx.Tag = cTBx.Text
            cTBx.BackColor = COULEUR_INITIALE
        End If
    End Sub
    Public Sub iTextBox_AvantMiseAjour(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_BeforeUpdate"
 
    End Sub
    Public Sub iTextBox_ApresMiseAjour()
        'saisir ici le code à déclencher dans "TextBox_AfterUpdate"
 
    End Sub
'------------------------------------------------------ Fin du code commun à toutes les classes de TextBox
 
 
'------------------------------------------------------ Evénements propres à la classe cTBDate
    Private Sub cTBx_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
        Dim ici As Byte, flt As String, cr As String, drf As String, dtt As String
        flt = "##" & SEP_DATE & "##" & SEP_DATE & "####"
        drf = "31" & SEP_DATE & "12" & SEP_DATE & "2000"
        With cTBx
            ici = .SelStart
            If KeyCode = 46 And .SelText = Mid(.Text, ici + 1) Then
                .Text = Left(.Text, ici)
                If Len(.Text) = 2 Or Len(.Text) = 5 Then .Text = Left(.Text, Len(.Text) - 1)
                KeyCode = 0: Exit Sub
            End If
            If ici < Len(.Text) Then .SelStart = Len(.Text): KeyCode = 0: Exit Sub
            If KeyCode = 8 Then
                If ici = 3 Or ici = 6 Then .Text = Left(.Text, Len(.Text) - 1)
                Exit Sub
            End If
            If KeyCode = 37 And ici = 0 Then
                If IsDate(.Tag) Then .Text = .Tag: KeyCode = 0: Exit Sub
            End If
            If KeyCode > 95 Then cr = Chr(KeyCode - 48)
            If ici = 3 Then Mid(drf, 1, 5) = IIf(cr = "0", "00" & SEP_DATE & "01", "00" & SEP_DATE & "02")
            dtt = .Text & cr & Mid(drf, ici + 2)
            If KeyCode = 32 Then
                If ici = 0 Or ici = 3 Or ici = 6 Or ici = 8 Then
                    Dim voir As String
                    voir = .Text & Mid(Format(Date, "dd" & SEP_DATE & "mm" & SEP_DATE & "yyyy"), ici + 1)
                    If IsDate(voir) Then .Text = voir
                End If
                KeyCode = 0:   Exit Sub
            End If
            If ici <> 8 Then
                If Not IsDate(dtt) Or Not dtt Like flt Then KeyCode = 0: Exit Sub
            Else
                If Not IsNumeric(cr) Then KeyCode = 0: Exit Sub
            End If
            Select Case ici
                Case 1, 4
                    If ici = 4 And Val(Mid(.Text, ici, 1) & cr) > 12 Then KeyCode = 0: Exit Sub
                    If ici = 4 Then
                        .Text = Left(dtt, Len(.Text & cr)) & SEP_DATE: KeyCode = 0
                    Else
                        .Text = Left(dtt, Len(.Text & cr)) & SEP_DATE: KeyCode = 0
                    End If
                Case 3
                    If cr > "1" Then KeyCode = 0
            End Select
        End With
        Application.CutCopyMode = True
    End Sub

Classe cTBHeure :
Saisie d'heures au format hh:mm

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
'------------------------------------------------------ Code commun à toutes les classes de TextBox
Option Explicit
 
Implements iTextbox
 
    Private Parent As iTextbox
    Private WithEvents cTBx As MSForms.TextBox
    Private Enable_Events As Boolean
 
    'création du "lien" avec l'Interface
    Private Sub Class_Initialize()
        Set Parent = New iTextbox
    End Sub
 
    'propriétés de l'Interface
    Public Sub iTextBox_Item(NewCtrl As Object, i As Long)
        Parent.item NewCtrl, i
        Set cTBx = NewCtrl
    End Sub
    Public Property Let iTextBox_Focus(booF As Boolean)
        Parent.Focus = booF
    End Property
    Public Property Get iTextBox_Focus() As Boolean
        iTextBox_Focus = Parent.Focus
    End Property
    Public Property Get iTextBox_Nom() As String
        iTextBox_Nom = Parent.Nom
    End Property
 
    'Méthode publique de l'Interface
    Public Sub iTextBox_Clear()
        Call Parent.Clear
    End Sub
 
    'événements supplémentaires, non gérés dynamiquement par les textbox, mais gérés ici par l'interface
    Public Sub iTextBox_Entree()
        'saisir ici le code à déclencher dans "TextBox_Enter"
        cTBx.BackColor = COULEUR_VISITEE
    End Sub
    Public Sub iTextBox_Sortie(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_Exit"
        If Len(cTBx.Text) < 5 Then Cancel = True: Exit Sub
        cTBx.BackColor = COULEUR_INITIALE
    End Sub
    Public Sub iTextBox_AvantMiseAjour(ByVal Cancel As MSForms.ReturnBoolean)
        'saisir ici le code à déclencher dans "TextBox_BeforeUpdate"
 
    End Sub
    Public Sub iTextBox_ApresMiseAjour()
        'saisir ici le code à déclencher dans "TextBox_AfterUpdate"
 
    End Sub
'------------------------------------------------------ Fin du code commun à toutes les classes de TextBox
 
 
'---------------------- Evénements propres à la classe cTBHeure :
    Private Sub cTBx_Change()
        'empêche la saisie d'heures farfelues exemple 45:89
        Select Case Len(cTBx)
            Case 1
                If cTBx.Value > 2 Then cTBx.Text = ""
            Case 2
                If cTBx.Value > 23 Then cTBx.Text = Left(cTBx, 1)
            Case 4
                If Right(cTBx.Text, 1) > 5 Then cTBx.Text = Left(cTBx.Text, 3)
            Case 5
                If Right(cTBx.Text, 2) > 59 Then cTBx.Text = Left(cTBx.Text, 4)
        End Select
        If Enable_Events Then Exit Sub
        If Len(cTBx) = 2 Then cTBx.Text = cTBx.Text & SEP_TIME
    End Sub
 
    Private Sub cTBx_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
        'flèche de suppression (retour arrière)
        If KeyCode = 8 Then Enable_Events = True: Exit Sub
        Enable_Events = False
        'Tabulation possible que si heure valide
        If KeyCode = 9 Then
            If Len(cTBx.Text) = 5 Then Exit Sub
        End If
        'si 5 caractères saisis, bloque la saisie
        If Len(cTBx) = 5 Then KeyCode = 0
        'n'accepte que les chiffres
        Select Case Shift
            Case 0
                If KeyCode < 96 Or KeyCode > 105 Then KeyCode = 0
            Case 1
                If KeyCode < 48 Or KeyCode > 57 Then KeyCode = 0
        End Select
    End Sub

Classe myContenairs :
Cette classe a été rendue obligatoire en fonction de la particularité des contrôles "conteneurs" (Page, Multipage, Frame).
Cette classe implémente également l'Interface pour contrôler la sortie de ces conteneurs.
En effet, selon les cas, la sortie du conteneur intervient avant la sortie du textbox. Ce qui provoquait des bugs dans les procédures "événementielles" _Exit, _Enter...

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
'------------------------------------------------------ Code commun à toutes les classes
Option Explicit
 
Implements iTextbox
 
    Private Parent As iTextbox
    Private WithEvents cFrame As MSForms.Frame
    Private WithEvents cMulti As MSForms.MultiPage
    Private cPage As MSForms.Page
 
    'création du "lien" avec l'Interface
    Private Sub Class_Initialize()
        Set Parent = New iTextbox
    End Sub
 
    'propriétés de l'Interface
    Public Sub iTextBox_Item(NewCtrl As Object, i As Long)
        Parent.item NewCtrl, i
        If TypeOf NewCtrl Is MSForms.Frame Then
            Set cFrame = NewCtrl
        ElseIf TypeOf NewCtrl Is MSForms.Page Then
            Set cPage = NewCtrl
        ElseIf TypeOf NewCtrl Is MSForms.MultiPage Then
            Set cMulti = NewCtrl
        End If
    End Sub
    Public Property Let iTextBox_Focus(booF As Boolean)
 
    End Property
    Public Property Get iTextBox_Focus() As Boolean
 
    End Property
    Public Property Get iTextBox_Nom() As String
        'iTextBox_Nom = Parent.Nom
    End Property
 
    'Méthode publique de l'Interface
    Public Sub iTextBox_Clear()
        Call Parent.Clear
    End Sub
 
    'événements supplémentaires, non gérés dynamiquement par les contrôles, mais gérés ici par l'interface
    Public Sub iTextBox_Entree()
        'le code déclenché dans "Frame_Enter" ou "MultiPage_Enter"
    End Sub
    Public Sub iTextBox_Sortie(ByVal Cancel As MSForms.ReturnBoolean)
        'le code déclenché dans "Frame_Exit" ou "MultiPage_Exit"
        Dim Conteneur As Object
        Select Case True
            Case TypeName(cFrame) = "Frame"
                Set Conteneur = cFrame
            Case TypeName(cMulti) = "MultiPage"
                Set Conteneur = cMulti.SelectedItem
            Case TypeName(cPage) = "Page"
                Set Conteneur = cPage
        End Select
        If Conteneur.ActiveControl Is Nothing Then Exit Sub
        If TypeOf Conteneur.ActiveControl Is MSForms.TextBox Then
            CallByName ItemByName(Conteneur.ActiveControl.Name), "Sortie", VbMethod, Cancel
        End If
    End Sub
 
    Public Sub iTextBox_AvantMiseAjour(ByVal Cancel As MSForms.ReturnBoolean)
    End Sub
    Public Sub iTextBox_ApresMiseAjour()
    End Sub
'------------------------------------------------------ Fin du code commun à toutes les classes
 
    Private Function ItemByName(Nom As String) As iTextbox
        Dim i As Integer
        For i = 1 To tbColl.Count
            If tbColl.item(i).Nom = Nom Then
                Set ItemByName = tbColl.item(i): Exit Function
            End If
        Next i
    End Function

A noter : Un bug, dans cette classe, intervient dans certains cas, lors de la fermeture de l'userform.
Je n'ai pas testé de solution, mais, à priori, une variable boolean Arret devrait suffire à débugger.

Dans chacune des classes ci-dessus, vous avez pu voir qu'une partie du code a été dite comme étant "commune à toutes les classes".
Il est bien entendu que les procédures Sortie, Entree, ApresMiseAjour et AvantMiseAjour, comportent chacune leur particularité selon la classe.
Merci à vous de m'avoir lu jusque là, et merci également pour vos éventuels retours.

A+
Franck