[Toutes versions] Optimisation Module de Classe

Bonjour à tous.

Dans un premier temps je tiens à remercier tous ceux qui alimentent ce forum. J’y ai trouvé la plupart des réponses aux problèmes que j’ai pu rencontrer dans mon apprentissage du VBA.

Pour me familiariser avec le VBA, je développe pas mal de procédures qui n’ont d’autres intérêts que de me permettre d’explorer le sujet.

Je viens donc vers vous avec le module de classe suivant. (clUserform chez moi)

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
Option Explicit
 
Private cpTitre As String ' Titre de l'USF à afficher
Private USF As Object ' Objet contenant l'USF
Private cpMonTxt() As Variant ' Variable tableau pour le texte à afficher dans l'USF
Private cpTextAlign() As Variant ' Variable tableau pour l'alignement de ce texte
 
 
'Récuperation et utilisation du Titre
Property Get Titre() As String
    Titre = cpTitre
End Property
Property Let Titre(ByVal NewValue As String)
    If Len(NewValue) > 60 Then
        Call GestionErreur(1)
    Else
        cpTitre = NewValue
    End If
End Property
 
 
'Récuperation et utilisation du texte à afficher
Property Get monTxt() As Variant()
    monTxt = cpMonTxt
End Property
Property Let monTxt(ByRef NewTab() As Variant)
    Dim i As Integer
    On Error GoTo 1
        If UBound(NewTab, 1) = 0 Then On Error GoTo 0: Call GestionErreur(2)
        If UBound(NewTab, 1) > 20 Then On Error GoTo 0: Call GestionErreur(3)
        For i = 0 To UBound(NewTab, 1)
            If Len(NewTab(i)) > 90 Then On Error GoTo 0: Call GestionErreur(4)  ' Moins de 90 caracteres par lignes
        Next i
    On Error GoTo 0
 
    cpMonTxt = NewTab
    Exit Property
1
     On Error GoTo 0: Call GestionErreur(5)
End Property
 
 
'Récuperation et utilisation des valeurs d'alignement
Property Get monAlign() As Variant()
    monAlign = cpTextAlign
End Property
Property Let monAlign(ByRef NewTab() As Variant)
    Dim i As Integer
    On Error GoTo 1
        If UBound(NewTab, 1) < UBound(monTxt, 1) Then On Error GoTo 0: Call GestionErreur(6)
        If UBound(NewTab, 1) > UBound(monTxt, 1) Then On Error GoTo 0: Call GestionErreur(7)
        For i = 0 To UBound(NewTab, 1)
            If NewTab(i) <> "g" And NewTab(i) <> "c" And NewTab(i) <> "d" Then On Error GoTo 0: Call GestionErreur(8) ' Gauche, Centre, Droite
        Next i
    On Error GoTo 0
 
    cpTextAlign = NewTab
    Exit Property
1
     On Error GoTo 0: Call GestionErreur(9)
End Property
 
 
 
Function Demande_Nbr() As Double
    Dim l_USF As Object
 
    If Titre = vbNullString Then Call GestionErreur(10)
 
    Set l_USF = addUSF()
    l_USF.Show
    ThisWorkbook.VBProject.VBComponents.Remove USF
    Set USF = Nothing
 
    Demande_Nbr = [passageValeur99]
    Names("passageValeur99").Delete
 
End Function
 
Private Function addUSF() As Object
 
    Dim Obj As Object
    Dim j As Integer
    Dim i As Integer
    Dim mt() As Variant
    Dim mt2() As Variant
    Dim LargLbl As Double
    Dim LeTop As Double
 
    Set USF = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
 
    '################   Code USF_Init       ########################
    'Suppression X
    With USF.CodeModule
        j = .CountOfLines
        .InsertLines j + 1, "Private Declare Function FindWindow Lib " & Chr(34) & "User32" & Chr(34) & " Alias " & Chr(34) & "FindWindowA" & Chr(34) & " (ByVal lpClassName As String, ByVal lpWindowName As String) As Long"
        .InsertLines j + 2, "Private Declare Function GetSystemMenu Lib " & Chr(34) & "User32" & Chr(34) & " (ByVal hwnd As Long, ByVal brevert As Long) As Long"
        .InsertLines j + 3, "Private Declare Function DeleteMenu Lib " & Chr(34) & "User32" & Chr(34) & " (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long"
        .InsertLines j + 4, "Private Const SC_CLOSE As Long = &HF060"
        .InsertLines j + 5, "   "
        .InsertLines j + 6, "Private Sub Userform_Initialize()"
        .InsertLines j + 7, "   Dim hWndForm As Long"
        .InsertLines j + 8, "   Dim hMenu As Long"
        .InsertLines j + 9, "   hWndForm = FindWindow(" & Chr(34) & "ThunderDFrame" & Chr(34) & ", Me.Caption)"
        .InsertLines j + 10, "  hMenu = GetSystemMenu(hWndForm, 0)"
        .InsertLines j + 11, "  DeleteMenu hMenu, SC_CLOSE, 0&"
        .InsertLines j + 12, "End sub"
    End With
 
    '################   Création des Labels ########################
 
    LeTop = 5
 
    mt = monTxt
    mt2 = monAlign
    LargLbl = 0
    For i = 0 To UBound(mt, 1)
        If Len(mt(i)) * 6 > LargLbl Then
            LargLbl = Len(mt(i)) * 6
        End If
    Next i
 
    If LargLbl < 60 Then
        LargLbl = 60
    End If
 
    For i = 0 To UBound(mt, 1)
        Set Obj = USF.Designer.Controls.Add("Forms.Label.1")
        With Obj
            .Left = 5
            .Top = LeTop
            LeTop = LeTop + 14
            .Width = LargLbl
            .Height = 12
            .Name = "LblText" & (i + 1)
            .Caption = mt(i)
            Select Case mt2(i)
                Case "g"
                    .TextAlign = fmTextAlignLeft
                Case "c"
                    .TextAlign = fmTextAlignCenter
                Case "d"
                    .TextAlign = fmTextAlignRight
            End Select
            .Font.Bold = True
        End With
        Set Obj = Nothing
    Next i
    LeTop = LeTop + 20
 
    '################   Création d'un TextBox  ########################
    Set Obj = USF.Designer.Controls.Add("Forms.TextBox.1")
 
    With Obj
        .Left = 5
        .Top = LeTop
        LeTop = LeTop + 30
        .Width = LargLbl
        .Height = 20
        .Name = "TxtReponse"
        .TextAlign = fmTextAlignCenter
    End With
 
    With USF.CodeModule
        j = .CountOfLines
        .InsertLines j + 1, "Sub TxtReponse_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)"
        .InsertLines j + 2, "   Dim UneVirgule as Boolean"
        .InsertLines j + 3, "   Dim i as Integer"
        .InsertLines j + 4, "   For i = 1 To Len(TxtReponse)"
        .InsertLines j + 5, "       If Mid(TxtReponse, i, 1) = Chr(46) Then UneVirgule = True"
        .InsertLines j + 6, "   Next i"
        .InsertLines j + 7, "   If (KeyAscii = 44 Or KeyAscii = 46) And UneVirgule = False Then"
        .InsertLines j + 8, "       KeyAscii = 46"
        .InsertLines j + 9, "   Else"
        .InsertLines j + 10, "       If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0"
        .InsertLines j + 11, "  End if"
        .InsertLines j + 12, "End Sub"
    End With
 
    '################   Création d'un CommandButton  ########################
    Set Obj = USF.Designer.Controls.Add("Forms.CommandButton.1")
    With Obj
        .Left = (LargLbl + 10) / 2 - 20
        .Top = LeTop
        LeTop = LeTop + 30
        .Width = 40
        .Height = 20
        .Name = "BTN_Valider"
        .Caption = "Valider"
    End With
    With USF.CodeModule
        j = .CountOfLines
        .InsertLines j + 1, "Sub BTN_Valider_Click()"
        .InsertLines j + 2, "   If TxtReponse = vbnullstring Then"
        .InsertLines j + 3, "       MsgBox " & Chr(34) & "Veuillez indiquer un montant !" & Chr(34)
        .InsertLines j + 4, "   else"
        .InsertLines j + 5, "       Names.Add Name:=" & Chr(34) & "passageValeur99" & Chr(34) & ", RefersTo:=Cdbl(Replace(TxtReponse," & Chr(34) & "." & Chr(34) & "," & Chr(34) & "," & Chr(34) & "))"
        .InsertLines j + 6, "       Unload me"
        .InsertLines j + 7, "   end if"
        .InsertLines j + 8, "end sub"
    End With
    '########################################################################
    With USF
        .Properties("Caption") = Titre
        .Properties("Width") = LargLbl + 10
        .Properties("Height") = LeTop + 30
    End With
    VBA.UserForms.Add (USF.Name)
    Set addUSF = UserForms(UserForms.Count - 1)
End Function
 
Private Sub GestionErreur(ByVal Num As Integer)
    Dim textErr As String
    textErr = "Initialisation de l'Userform impossible" & Chr(13) & Chr(13)
    Select Case Num
        Case 1
            textErr = textErr + "Impossible d'affecter un titre de plus de 60 caracteres !"
        Case 2
            textErr = textErr + "Erreur monTxt - Vous avez n'avez renseigné aucune ligne !"
        Case 3
            textErr = textErr + "Erreur monTxt - Vous avez renseigné plus de 20 lignes !"
        Case 4
            textErr = textErr + "Erreur monTxt - Vous avez renseigné une ligne de plus de 90 caracteres !"
        Case 5
            textErr = textErr + "Erreur monTxt !" ' à modifier
        Case 6
            textErr = textErr + "Erreur Tab Align - Paramètres manquants !"
        Case 7
            textErr = textErr + "Erreur Tab Align - Paramètres en trop !"
        Case 8
            textErr = textErr + "Erreur Tab Align - g,c et d seulement sont acceptés !"
        Case 9
            textErr = textErr + "Erreur Tab Align !" 'à modifier
        Case 10
            textErr = textErr + "Veuillez definir un titre!"
    End Select
    Err.Raise vbObjectError + 1, , textErr
 
End Sub

Ainsi que le code appelant

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
Option Explicit
 
Sub Test_Userform()
 
    Dim MonObjet As clUserform
    Dim Nombre As Double
    Dim mt() As Variant
    Dim mt2() As Variant
    'Dim Ws As Worksheet
    'Dim rng As Range
    Dim leTitre As String
    'Dim i As Integer, j As Integer
 
    'Set Ws = ThisWorkbook.Worksheets("Feuil3")
    'With Ws
        'For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row Step 2
            'Set rng = .Range(.Cells(i, 2), .Cells(i, .Cells(i, .Columns.Count).End(xlToLeft).Column))
            'ReDim mt(0 To rng.Columns.Count - 1)
            'ReDim mt2(0 To rng.Columns.Count - 1)
            'For j = 2 To rng.Columns.Count + 1
                'mt(j - 2) = .Cells(i, j)
                'mt2(j - 2) = .Cells(i + 1, j)
            'Next j
            'leTitre = .Cells(i, 1)
 
            Set MonObjet = New clUserform
            With MonObjet
                .Titre = "Ceci est le titre"
                '.Titre = leTitre
                mt() = Array("Bonjour", "ceci est un test ------------------", "dimanche", "Lundi")
                mt2() = Array("g", "c", "d", "c")
                .monTxt = mt()
                .monAlign = mt2()
                Nombre = .Demande_Nbr()
            End With
 
            'Erase mt()
            'Erase mt2()
 
            Set MonObjet = Nothing
 
            MsgBox Nombre
        'Next i
    'End With
 
End Sub

Le but du ce sujet n’est pas spécialement de discuter sur l’apparence du l’Userform, ni de son utilité. (Bien que je sois à l’écoute de toute suggestion)
Mais plutôt sur l’organisation du module de classe ainsi que sur sa relation avec le code appelant.
Car à vrai dire, le code fonctionne, mais je reste perplexe, j’ai l’impression de me compliquer les choses. Le but de cet essai étant de me familiariser avec les modules de classe avant d’entamer un projet beaucoup plus complexe. J’aimerai cerner au plus vite les défauts de conception de mon projet.

-------------------------------------------------------------------------------
J’ai également une question concernant le module de classe :

J’ai essayé plusieurs manière différentes pour regrouper mes lignes de texte et mes critères d’alignement dans une même propriété (Variable tableau à plusieurs dimension, Type Personnalisé ), mais sans succès, si quelqu’un connait une solution, je suis preneur.

Merci d’avance pour votre aide =)