Discussion :

[Invité]

bien évidement, il est possible de tout placer dans le module de classe et de ne laisser que Usf.Show dans le sub test

Code Module de classe :

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
#If VBA7 Then
    Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe  Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare PtrSafe  Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare  PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 #Else
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = &HF060&
Private Const MF_BYCOMMAND = &H0&
 Dim hwnd As Long, Style As Long
Public Usf As Object
Private Nom As String
Private Dico As Object
 
Public WithEvents Bouton As MSForms.CommandButton
'Initialise la collection
Private Sub Class_Initialize()
 Set Dico = CreateObject("Scripting.dictionary")
End Sub
'permet de créer un UserForm
Public Sub NewUsf(Caption As String, Width As Double, Height As Double)
Set Usf2 = ThisWorkbook.VBProject.VBComponents.Add(3)
Nom = Usf2.Name
  VBA.UserForms.Add (Nom)
 Set Usf = UserForms(UserForms.Count - 1)
With Usf
    .Caption = Caption
    .Width = Width
    .Height = Height
  End With
 
End Sub
'Ouvre le UserForm
Public Sub Show()
Usf_Initialize
Usf.Show
End Sub
'Permet d'ajouter un bouton
Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
If Dico.EXISTS(Name) = True Then Exit Sub
Dim cls As New Classe1
 Set cls.Bouton = Usf.Controls.Add("forms.CommandButton.1")
 Set cls.Usf = Usf
    With cls.Bouton
        .Name = Name
        .Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub
'permet de supprimer le UserForm
Private Sub Class_Terminate()
If Nom <> "" Then
 Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
End If
End Sub
'L'evennement Click Bouton7 ferme le UserForm
Private Sub Bouton_Click()
Select Case Bouton.Name
Case "Bouton7"
    Unload Usf
Case Else
    MsgBox Bouton.Name
End Select
End Sub
'code se déclenchant à l'ouverture de Userform1
Private Sub Usf_Initialize()
Dim hSysMenu As Long
Dim MeHwnd As Long
    MeHwnd = FindWindowA(vbNullString, Usf.Caption)
    If MeHwnd > 0 Then
        hSysMenu = GetSystemMenu(MeHwnd, False)
        RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
    Else
        MsgBox "Handle de " & Usf.Caption & " Introuvable", vbCritical
    End If
 
End Sub

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
Sub test()
Dim Usf As New Classe1
'With Me
'    .Height = Obj.Height + Obj.Top + (5 * (i - 2))
'    .Width = (Obj.Left * 2) + Obj.Width
'End With
Usf.NewUsf "toto", (20 * 2) + 100, (30 * 7) + 5 + (5 * 5)
'module de classe
'Public Sub NewUsf(Caption As String, Width As Double, Height As Double)
'Set Usf2 = ThisWorkbook.VBProject.VBComponents.Add(3)
'Nom = Usf2.Name
'  VBA.UserForms.Add (Nom)
' Set Usf = UserForms(UserForms.Count - 1)
'With Usf
'    .Caption = Caption
'    .Width = Width
'    .Height = Height
'  End With
'
'End Sub
For i = 1 To 7
  Usf.NewBouton "Bouton" & i, "Bouton " & i, 100, 30, 20, 30 * (i - 1) + 5
  'module de classe
'sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
'If Dico.EXISTS(Name) = True Then Exit Sub
'Dim cls As New Classe1
' Set cls.Bouton = Usf.Controls.Add("forms.CommandButton.1")
' Set cls.Usf = Usf
'    With cls.Bouton
'        .Name = Name
'        .Caption = Caption
'        .Width = Width
'        .Height = Height
'        .Left = Left
'        .Top = Top
'    End With
'
'   Dico.Add Name, cls
'   Set cls = Nothing
'End Sub
Next
 
Usf.Show
'Module de classe code se déclenchant à l'ouverture de Userform1
'pour rendre la croix inopérente!
'Private Sub Usf_Initialize()
'Dim hSysMenu As Long
'Dim MeHwnd As Long
'    MeHwnd = FindWindowA(vbNullString, Usf.Caption)
'    If MeHwnd > 0 Then
'        hSysMenu = GetSystemMenu(MeHwnd, False)
'        RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
'    Else
'        MsgBox "Handle de " & Usf.Caption & " Introuvable", vbCritical
'    End If
'
'End Sub
End Sub

[pijaku]

Bonjour,

On en était arrivé là lors de ma réponse du 20/04/2015, 14h58.
A savoir que l'on avait deux choix :
- soit on intègre la création des contrôles dans le code appelant (solution de rdurupt 21/04/2015, 16h32),
cette solution permet de faire réagir les contrôles grâce à la classe
- soit on ne laisse rien dans la partie appelante que l'appel de notre objet.

C'est cette seconde possibilité qui a été retenue.
En effet, laisser la création des contrôles dans la partie appelante, c'est un peu comme vendre une calculatrice sans bouton ni écran.

Maintenant que le choix s'est porté sur la seconde solution, nous étudions les différentes possibilités pour rendre nos contrôles actifs.

Pierre a eu l'idée de créer, par code, le code de l'UserForm.
Cette solution est efficace. Cependant, n'en existe t'il pas une autre?

N'est-il pas possible d'intégrer au module de classe une sous-classe qui gèrerait les contrôles?

J'ai lu qu'il était possible de créer des propriétés Objets. Ne peut-on pas s'en servir pour créer les contrôles dans notre UserForm?

En fait, on touche vraiment là à mes limites de connaissances dans les classes.

Une solution consisterait à créer deux Modules de classe. Je n'en suis pas fan, mais pourquoi pas après tout.

Qu'en pensez-vous, vous qui maitrisez davantage cet aspect de la programmation?

ps : sur ce je vais replonger dans l'étude de la réponse de Pierre Fauconnier à propos de : programmation de type "trois-tiers". Partie que je n'ai toujours pas comprise...

[Invité]

Bonjour,
Ma solution travail déjà comme ça puisqu'elle place les boutons dans une autre instance de la même classe!

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
Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
If Dico.EXISTS(Name) = True Then Exit Sub
Dim cls As New Classe1
 Set cls.Bouton = Usf.Controls.Add("forms.CommandButton.1")
 Set cls.Usf = Usf
    With cls.Bouton
        .Name = Name
        .Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub

[pijaku]

Oui. J'ai bien vu cela.
Mais ce que je ne parviens pas à faire c'est intégrer la boucle de création des contrôles dans le module de classe :

Code :

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

1
2
3
For i = 1 To 7
  Usf.NewBouton "Bouton" & i, "Bouton " & i, 100, 30, 20, 30 * (i - 1) + 5
Next

Ce code ne devrait pas, à terme, rester du côté appel de l'objet.

[Pierre Fauconnier]

Il faudra que je me penche sur la solution de rdurupt, car je ne l'ai pas encore mise en pratique.

[...]

N'est-il pas possible d'intégrer au module de classe une sous-classe qui gèrerait les contrôles?

J'ai lu qu'il était possible de créer des propriétés Objets. Ne peut-on pas s'en servir pour créer les contrôles dans notre UserForm?
[...]

Tu peux créer une propriété Objet, mais elle aura besoin de son module de classe => deux modules... Alors que c'est ce que nous cherchons à éviter...

[...]Une solution consisterait à créer deux Modules de classe. Je n'en suis pas fan, mais pourquoi pas après tout.[...]

Voir ma remarque précédente!

Donc pour moi, si l'on veut un seul module, on doit forcément créer le code à l'intérieur de ce module. Dans la mesure où l'on peut créer le userform avant pour le tester, je ne vois pas trop le problème...

[Invité]

Code classe :

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
#If VBA7 Then
    Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe  Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare PtrSafe  Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare  PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 #Else
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = &HF060&
Private Const MF_BYCOMMAND = &H0&
 Dim hwnd As Long, Style As Long
Public Usf As Object
Private Nom As String
Private Dico As Object
 
Public WithEvents Bouton As MSForms.CommandButton
'Initialise la collection
Private Sub Class_Initialize()
 Set Dico = CreateObject("Scripting.dictionary")
End Sub
'permet de créer un UserForm
Private Sub NewUsf(Caption As String, Width As Double, Height As Double)
Set Usf2 = ThisWorkbook.VBProject.VBComponents.Add(3)
Nom = Usf2.Name
  VBA.UserForms.Add (Nom)
 Set Usf = UserForms(UserForms.Count - 1)
With Usf
    .Caption = Caption
    .Width = Width
    .Height = Height
  End With
 
End Sub
'Ouvre le UserForm
Public Sub Show()
NewUsf "toto", (20 * 2) + 100, (30 * 7) + 5 + (5 * 5)
For i = 1 To 7
  NewBouton "Bouton" & i, "Bouton " & i, 100, 30, 20, 30 * (i - 1) + 5
Next
Usf_Initialize
Usf.Show
End Sub
'Permet d'ajouter un bouton
Private Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
If Dico.EXISTS(Name) = True Then Exit Sub
Dim cls As New Classe1
 Set cls.Bouton = Usf.Controls.Add("forms.CommandButton.1")
 Set cls.Usf = Usf
    With cls.Bouton
        .Name = Name
        .Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub
'permet de supprimer le UserForm
Private Sub Class_Terminate()
If Nom <> "" Then
 Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
End If
End Sub
'L'evennement Click Bouton7 ferme le UserForm
Private Sub Bouton_Click()
Select Case Bouton.Name
Case "Bouton7"
    Unload Usf
Case Else
    MsgBox Bouton.Name
End Select
End Sub
'code se déclenchant à l'ouverture de Userform1
Private Sub Usf_Initialize()
Dim hSysMenu As Long
Dim MeHwnd As Long
    MeHwnd = FindWindowA(vbNullString, Usf.Caption)
    If MeHwnd > 0 Then
        hSysMenu = GetSystemMenu(MeHwnd, False)
        RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
    Else
        MsgBox "Handle de " & Usf.Caption & " Introuvable", vbCritical
    End If
 
End Sub

Code :

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

1
2
3
4
Sub test()
Dim Usf As New Classe1
Usf.Show
End Sub

[pijaku]

Bonjour,

Voici l'exemple, un jeu de démineur, réalisé grâce à vos explications.

Il convient toujours de cocher deux références : Microsoft Forms 2.0 Object Library et Microsoft Visual Basic For Applications Extensibility 5.3.
De plus, dans les options Excel, doit être cochée la case : "accès approuvé au modèle objet du projet VBA". Si elle ne l'est pas, il n'y aura pas d'erreur, et vous serez informés.

Je renouvelle mes remerciements à tous les participants de ce sujet ainsi qu'aux (nombreux) lecteurs qui sont par ailleurs cordialement invités à donner leur avis.

Le code appelant :

Code :

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

1
2
3
4
5
6
7
Option Explicit
Sub test()
Dim Userf As New cDemineur
'pour actionner le mode "triche", enlevez l'apostrophe dans la ligne suivante
'0 = facile, 1 = moyen, 2 = difficile
Userf.Show 0 ', True
End Sub

Le code de la classe :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
Option Explicit
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Nécessite de cocher les deux références suivantes (Menu Outils/Références)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
'Variables publiques
Public maForm As Object                                         'Userform
Public Fram As MSForms.Frame                                    'Frame = conteneur des boutons
Public Dico As Object                                           'Objet dictionary
Public DicoParent As Object                                     'Objet dictionary
Public TypeObjet As String                                      'Type d'objet (Ici, soit "Userform", soit "Frame")
Public Mine As Boolean                                          'Propriété Mine si True = bouton piégé
Public Decouverte As Boolean                                    'Propriété Découverte si True = "terrain(bouton) déminé"
'variables privées
Private Nom As String                                           'Nom => permet la construction et la destruction de l'userform
Private cVoisins() As cDemineur                                 'propriété sous forme de tableau listant les boutons voisins
'variables publiques "événementielles"
Public WithEvents Bouton As MSForms.CommandButton               'Bouton
'constantes
Private Const LARG_BTN As Byte = 18                             'taille des boutons
Private Const MIN_LIGN As Byte = 7                              'minimum de lignes
Private Const MAX_LIGN As Byte = 30 - MIN_LIGN                  'maximum de lignes
Private Const MIN_COL As Byte = 7                               'minimum de colonnes
Private Const MAX_COL As Byte = 40 - MIN_COL                    'maximum de colonnes
Private Const POURCENT_SIMPLE As Byte = 10                      '%age de mines en mode facile
Private Const POURCENT_MEDIUM As Byte = 2 * POURCENT_SIMPLE     '%age de mines en mode médium
Private Const POURCENT_HARD As Byte = 3 * POURCENT_SIMPLE       '%age de mines en mode difficile
Private Const COUL_MINE As Long = &H188B0                       'couleur des boutons minés (pour les dévoiler)
Private Const COUL_BOUTON As Long = &H8000000F                  'couleur des boutons
Private Const COUL_MINE_POSSIBLE As Long = &H80FF&              'couleur si bouton possiblement miné (bouton affiche ?) => doute
Private Const COUL_MINE_PROB As Long = &H8080FF                 'couleur si bouton probablement miné (bouton affiche !) => attention danger
 
Property Get Voisins() As cDemineur()
'propriété Voisins en Lecture
   Voisins = cVoisins
End Property
 
Property Let Voisins(ByRef nouvVoisins() As cDemineur)
'propriété Voisins en Ecriture
   cVoisins = nouvVoisins
End Property
 
Private Sub Class_Initialize()
'constructeur de la classe cDémineur
    Set Dico = CreateObject("Scripting.dictionary")
End Sub
 
Public Sub Show(ByRef Difficult As Long, Optional ModeTriche As Boolean = False)
'Méthode Show : permet l'affichage de l'Userform
    On Error GoTo ErreurParametresMacros        'vérification si "accès approuvé au modèle objet du projet VBA" est cochée dans les options Excel
    With ThisWorkbook.VBProject: End With
 
    Dim Lign As Long, Col As Long, NbLignes As Long, NbColonnes As Long
    Dim NbMines As Long, MineAdress() As String, CptMine As Long
    Randomize Timer                             'initialisation générateur de nombres aléatoires
    NbLignes = Int(MAX_LIGN * Rnd) + MIN_LIGN   'Nombre de lignes de boutons
    NbColonnes = Int(MAX_COL * Rnd) + MIN_COL   'Nombre de colonnes de boutons
    Select Case Difficult                       'Nombre de Mines selon la difficulté choisie
        Case 0: Difficult = POURCENT_SIMPLE
        Case 1: Difficult = POURCENT_MEDIUM
        Case 2: Difficult = POURCENT_HARD
    End Select
    NbMines = (NbLignes * NbColonnes) * Difficult \ 100
    ReDim MineAdress(NbMines)
    For CptMine = 1 To NbMines                   'coordonnées des Mines (Colonne & "-" & Ligne)
        MineAdress(CptMine) = Int(NbColonnes * Rnd) + 1 & "-" & Int(NbLignes * Rnd) + 1
    Next
    Call Creation_Usf("Démineur", (NbColonnes * LARG_BTN) + 5, (NbLignes * LARG_BTN) + 22)  'création Userfom
    Call Nouveau_Frame("Fram1", "", NbColonnes * LARG_BTN, NbLignes * LARG_BTN)             'création Frame
    For Lign = 1 To NbLignes                                                                'création Boutons
        For Col = 1 To NbColonnes
            Call Dico("Fram1").Nouveau_Bouton(Col & "-" & Lign, "", LARG_BTN * (Col - 1), LARG_BTN * (Lign - 1), EstDans(Col & "-" & Lign, MineAdress), ModeTriche)
            Set Dico("Fram1").Dico(Col & "-" & Lign).DicoParent = Dico("Fram1").Dico
        Next Col
    Next Lign
    maForm.Show
    Exit Sub
ErreurParametresMacros:
    MsgBox "Veuillez vérifier que vous avez approuvé l'accès au modèle objet du projet VBA."
End Sub
 
Private Sub Creation_Usf(Titre As String, Largeur As Double, Hauteur As Double)
'création Userfom
    TypeObjet = "UserForm"
    Set maForm = ThisWorkbook.VBProject.VBComponents.Add(3)
    Nom = maForm.Name
    VBA.UserForms.Add (Nom)
    Set maForm = UserForms(UserForms.Count - 1)
    With maForm
        .Caption = Titre
        .Width = Largeur
        .Height = Hauteur
    End With
End Sub
 
Public Sub Nouveau_Frame(monNom As String, Titre As String, Largeur As Double, Hauteur As Double)
'création Frame
    If Dico.Exists(monNom) = True Then Exit Sub
    Dim maClass As New cDemineur
    Select Case TypeObjet
        Case "UserForm": Set maClass.Fram = maForm.Controls.Add("forms.frame.1")
        Case "Frame": Set maClass.Fram = Fram.Controls.Add("forms.frm.1")
    End Select
    maClass.TypeObjet = "Frame"
    Set maClass.maForm = maForm
    With maClass.Fram
        .Name = monNom
        .Caption = Titre
        .Move 0, 0, Largeur, Hauteur
    End With
    Dico.Add monNom, maClass
    Set maClass = Nothing
End Sub
 
Public Sub Nouveau_Bouton(monNom As String, Titre As String, Gauche As Double, Haut As Double, boolMine As Boolean, Optional ModeTriche As Boolean)
'création Boutons
    If Dico.Exists(monNom) = True Then Exit Sub
    Dim maClass As New cDemineur
    Select Case TypeObjet
        Case "UserForm": Set maClass.Bouton = maForm.Controls.Add("forms.CommandButton.1")
        Case "Frame": Set maClass.Bouton = Fram.Controls.Add("forms.CommandButton.1")
    End Select
    Set maClass.maForm = maForm
    maClass.Mine = boolMine
    With maClass.Bouton
        .Name = monNom
        .Caption = Titre
        .Move Gauche, Haut, LARG_BTN, LARG_BTN
        If ModeTriche Then
            If boolMine Then .BackColor = COUL_MINE Else .BackColor = COUL_BOUTON
        Else
            .BackColor = COUL_BOUTON
        End If
    End With
    Dico.Add monNom, maClass
    Set maClass = Nothing
End Sub
 
Private Function EstDans(adresse As String, Tb) As Boolean
'fonction de recherche d'une valeur dans une var tableau
    Dim i As Long
    For i = 0 To UBound(Tb)
        If Tb(i) = adresse Then EstDans = True: Exit Function
    Next i
End Function
 
Private Sub Bouton_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
'Procédure événementielle lors de l'appui, à l'aide d'un des 2 boutons de la souris, sur un Bouton de l'Userform
    If Button = XlMouseButton.xlSecondaryButton Then    'clic droit
        Select Case Bouton.Caption 'selon le Caption du bouton 4 possibilités
            Case "": Bouton.Caption = "!": Bouton.BackColor = COUL_MINE_PROB        'si caption est vide : on affiche ! (= attention danger)
            Case "!": Bouton.Caption = "?": Bouton.BackColor = COUL_MINE_POSSIBLE   'si caption est ! : on affiche ? (= doute)
            Case "?": Bouton.Caption = "": Bouton.BackColor = COUL_BOUTON           'si caption est ? : on affiche rien (= levée du doute)
            Case Else:                                                              'sinon (caption = chiffre (Nbre de mines voisines)) On ne fait rien
        End Select
    ElseIf Button = XlMouseButton.xlPrimaryButton Then  'clic gauche
        If DicoParent.Item(Bouton.Name).Mine Then                                   'si bouton miné
            Call Affiche_Toutes_Mines                                               'affichage de toutes les mines
            MsgBox "Partie perdue"                                                  'message
            maForm.Hide                                                             'on quitte
        Else                                                                        'si bouton non miné
            Bouton.BackColor = COUL_BOUTON                                          'remet la couleur par défaut en cas de clic droit précédent
            Dim maClass As cDemineur                                                'on appelle la procédure de déminage
            Set maClass = DicoParent.Item(Bouton.Name)                              'procédure récursive de propagation
            Call Demine(maClass)                                                    'des boutons dont les voisins de sont pas des mines
        End If
    End If
    If Partie_Gagnee Then
        Call Affiche_Toutes_Mines
        MsgBox "Partie Gagnée."
        maForm.Hide
    End If
End Sub
 
Private Sub Affiche_Toutes_Mines()
'En cas de partie perdue, colore tous les boutons minés
Dim cle As Variant
    For Each cle In DicoParent.Keys
        If DicoParent.Item(cle).Mine Then DicoParent.Item(cle).Bouton.BackColor = COUL_MINE
    Next
End Sub
 
Private Sub Demine(Cl As cDemineur)
'procédure récursive de propagation de la découverte des boutons non minés
Dim NbMines As Integer
    NbMines = CompteMines(Cl.Bouton.Name)
    If NbMines > 0 Then
        Cl.Bouton.Caption = NbMines
        Cl.Decouverte = True
        Cl.Bouton.BackColor = COUL_BOUTON
    Else
        If Cl.Decouverte = False Then
            Cl.Decouverte = True
            Cl.Bouton.Visible = False
            Quels_Voisins Cl
            Dim Tb() As cDemineur, i As Integer
            Tb = Cl.Voisins
            For i = 0 To UBound(Tb)
                Demine Tb(i)
            Next
        End If
    End If
End Sub
 
Private Function CompteMines(Bout As String) As Integer
'fonction comptant les mines contenues dans les boutons voisins
Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
Dim maClass As cDemineur
    For i = -1 To 1
        For j = -1 To 1
            Col = CInt(Split(Bout, "-")(0)) + i
            Lig = CInt(Split(Bout, "-")(1)) + j
            If DicoParent.Exists(Col & "-" & Lig) Then
                Set maClass = DicoParent.Item(Col & "-" & Lig)
                If maClass.Mine Then CompteMines = CompteMines + 1
            End If
        Next j
    Next i
End Function
 
Private Sub Quels_Voisins(Cl As cDemineur)
'procédure affectant, à la propriété Voisins() d'un bouton, la liste des boutons qui l'entourent
Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
Dim maClass As cDemineur, ListeVoisins() As cDemineur, cpt As Byte
    For i = -1 To 1
        For j = -1 To 1
            Col = CInt(Split(Cl.Bouton.Name, "-")(0)) + i
            Lig = CInt(Split(Cl.Bouton.Name, "-")(1)) + j
            If DicoParent.Exists(Col & "-" & Lig) And Cl.Bouton.Name <> Col & "-" & Lig Then
                Set maClass = DicoParent.Item(Col & "-" & Lig)
                ReDim Preserve ListeVoisins(cpt)
                Set ListeVoisins(cpt) = maClass
                cpt = cpt + 1
            End If
        Next j
    Next i
    Cl.Voisins = ListeVoisins
End Sub
 
Private Function Partie_Gagnee() As Boolean
Dim cle As Variant
    For Each cle In DicoParent.Keys
        If DicoParent.Item(cle).Decouverte = False And DicoParent.Item(cle).Mine = False Then Partie_Gagnee = False: Exit Function
    Next
    Partie_Gagnee = True
End Function
 
Private Sub Class_Terminate()
'destructeur de la classe cDémineur
    Dim VBComp As VBComponent
    Set Dico = Nothing
    If Nom <> "" Then
        Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
        ThisWorkbook.VBProject.VBComponents.Remove VBComp
    End If
End Sub

[Pierre Fauconnier]

Perso, je préfère la méthode de rdurupt à la mienne, car elle permet d'avoir le code de gestion en clair dans la classe, ce qui est plus maintenable.

Et on peut ajouter autre chose que des boutons à la collection des contrôles. Le code de la classe peut alors récupérer les valeurs saisies dans les textbox, les valeurs des checkbox et autres. Cela permet alors d'avoir effectivement un "userform".

Cela étant, l'idée est tout de même d'avoir un userform dont le nombre (et éventuellement le type de contrôles) sont modifiables par la procédure appelante du userform. Il faudra donc, comme le propose rdurupt:

• soit que la procédure appelante puisse passer un tableau de contrôles qui seront créés (cela limite les possibilités de développement de code métier à l'intérieur de la classe);
• soit qu'avant d'activer une méthode Show, on puisse alimenter la collection des contrôles. (comme le montrait rdurupt dans son message de hier 14h12.

Parce qu'un simple appel de type maclasse.show n'a aucun sens puisque le formulaire créé serait toujours le même. Dans ce cas, autant avoir le userform directement, non?

Donc, perso, j'opterai pour une méthode dynamique qui construit tout en une seule passe, du genre maclasse.show caption, left, top, width, height, controls_table...

[Invité]

Bonsoir Pierre,
d'accord avec toi; sauf s’offrir un exercice de style, du genre moi je sais faire, cela revient comme tu l'as dit à un UserForm standard!

la génération dans un module standard des contrôles, permet un chaînage des dicos Usf.dico("MultiPage").NewBouton("etc...")ainsi de générer tout ou presque; seule l'imagination et la technique pourrait en limité le processus!

[pijaku]

Bonjour Messieurs,

Je vais tenter d'être clair.
@Pierre Fauconnier

Parce qu'un simple appel de type maclasse.show n'a aucun sens puisque le formulaire créé serait toujours le même. Dans ce cas, autant avoir le userform directement, non?

Oui et non en fait. Ma question initiale le montre d'ailleurs.
A titre d'exemple (bidon mais explicite) :
Soit un Userform comportant 365 boutons (un par jour). Le clic sur un bouton renvoie le jour cliqué.
En utilisant uniquement un UserForm, le développeur se doit d'écrire 365 Sub événementielle CommandButtonXXX_Click.
Il peut donc, pour se simplifier la vie utiliser 1 UserForm et 1 Classe ce qui "complique" le "travail" de l'utilisateur.
Notre méthode permet ainsi de simplifier le travail du développeur en lui permettant de "livrer" un produit simple d'utilisation.
Le fait de disposer d'une classe permet également de donner à la disposition de l'utilisateur une propriété Value à son objet.
Ainsi, l'utilisation dans son classeur est rendue encore plus aisée. Chaque utilisateur, même novice, sachant quoi faire avec monObjet.Value.
Soit il veut la valeur dans une cellule : [B5] = monObjet.Value, soit il la veut dans un TextBox de son Userform : Me.Textbox1 = monObjet.Value.
[ps : ceci est faisable également avec un userform, mais de manière un peu plus "complexe" pour l'utilisateur, je trouve en tous cas.]

Le code de la classe peut alors récupérer les valeurs saisies dans les textbox, les valeurs des checkbox et autres.

J'ai justement beaucoup de mal à récupérer ces valeurs, lors d'un clic sur un bouton, etc...
Mais à force de tentatives, je devrais trouver... ou pas

Cela étant, l'idée est tout de même d'avoir un userform dont le nombre (et éventuellement le type de contrôles) sont modifiables par la procédure appelante du userform.

Oui, mais de manière simplifiée.
La collection des contrôles prévue pour telle ou telle configuration de l'userform devrait, selon moi, être développée, au sein de la classe, afin que l'appel en reste simplifié.
Par exemple (en faux code) :

Code :

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

1
2
3
Sub Appel()
  MonObjet.Show 1
End Sub

dans la classe

Code :

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

1
2
3
4
5
6
Sub Show(QuelUsf As Integer)
Select Case QuelUsf
  Case 1: 
  Case 2:
End Select
End Sub

@rdurupt

Code :

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

1
2
3
4
Private sub SuppNouton(Nom)
Usf.controls.remove cstr(nom)
Dico.remove nom
End sub

Ce n'est pas ce que je demandais en fait. ça, je sais faire (il est vrai que ne se connaissant pas, il est toujours difficile d'évaluer le niveau d'un correspondant sur un forum).
En fait, lors de la création d'un nouveau bouton, on créé une nouvelle instance de classe.
Comment la supprimer lors de la destruction de ce contrôle?
Est ce possible et surtout est ce utile?
Supposons à l’extrême, que notre objet comporte des milliers de contrôles à créer et effacer plusieurs fois dans la même utilisation.
Cela ne va t'il pas engendrer une "saturation" de la mémoire?

la génération dans un module standard des contrôles, permet un chaînage des dicos Usf.dico("MultiPage").NewBouton("etc...")ainsi de générer tout ou presque

Une fois de plus, vous atteignez ici la limite de mes connaissances.
Pourrais-tu, stp, nous "bricoler" un petit exemple afin que je comprennes là ou tu veux en venir?

En tout cas, merci pour le suivi et le partage de vos connaissances.

[Invité]

Bonjour,
on libère les instance dans la méthode Class_Terminate().
vue que Dico contient les instances il suffit de libérer Set Dico = Nothing pour supprimer toutes les instance!

les contrôles sont décharger avec le unload Usf vue qu'il font partie intégrante du Usf.Controls.Add("forms.CommandButton.1")!

Code :

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

1
2
3
4
5
6
7
8
permet de supprimer le UserForm
Private Sub Class_Terminate()
 Set Dico = Nothing
If Nom <> "" Then
    Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
End If
End Sub

dans l'exemple suivant, j'ai remplace Bouton1 par textbox1

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
#If VBA7 Then
    Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe  Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare PtrSafe  Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare  PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 #Else
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = &HF060&
Private Const MF_BYCOMMAND = &H0&
 Dim hwnd As Long, Style As Long
Public Usf As Object
Private Nom As String
Private Dico As Object
 
Public WithEvents Bouton As MSForms.CommandButton
Public WithEvents Text As MSForms.TextBox
 
 
'Initialise la collection
Private Sub Class_Initialize()
 Set Dico = CreateObject("Scripting.dictionary")
End Sub
Private Sub NewTxt(Name As String, TxtDefaut As String, Width As Double, Height As Double, Left As Double, Top As Double)
If Dico.EXISTS(Name) = True Then Exit Sub
Dim cls As New Classe1
  Set cls.Text = Usf.Controls.Add("forms.Textbox.1")
 Set cls.Usf = Usf
    With cls.Text
        .Name = Name
        .Text = TxtDefaut
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub
'permet de créer un UserForm
Private Sub NewUsf(Caption As String, Width As Double, Height As Double)
Set Usf2 = ThisWorkbook.VBProject.VBComponents.Add(3)
Nom = Usf2.Name
  VBA.UserForms.Add (Nom)
 Set Usf = UserForms(UserForms.Count - 1)
With Usf
    .Caption = Caption
    .Width = Width
    .Height = Height
  End With
 
End Sub
'Ouvre le UserForm
Public Sub Show()
 
NewUsf "toto", (20 * 2) + 100, (30 * 7) + 5 + (5 * 5)
NewTxt "TxtBox1", "Bouton", 100, 30, 20, 30 * (1 - 1) + 5
For I = 2 To 7
  NewBouton "Bouton" & I, "Bouton " & I, 100, 30, 20, 30 * (I - 1) + 5
Next
Usf_Initialize
Usf.Show
End Sub
'Permet d'ajouter un bouton
Private Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
If Dico.EXISTS(Name) = True Then Exit Sub
Dim cls As New Classe1
  Set cls.Bouton = Usf.Controls.Add("forms.CommandButton.1")
 Set cls.Usf = Usf
    With cls.Bouton
        .Name = Name
        .Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
 
 
End Sub
 
'permet de supprimer le UserForm
Private Sub Class_Terminate()
Dim I As Integer
 Set Dico = Nothing
If Nom <> "" Then
    Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
End If
End Sub
'L'evennement Click Bouton7 ferme le UserForm
Private Sub Bouton_Click()
Select Case Bouton.Name
Case "Bouton7"
    Unload Usf
Case Else
    MsgBox Bouton.Name
End Select
End Sub
'code se déclenchant à l'ouverture de Userform1
Private Sub Usf_Initialize()
Dim hSysMenu As Long
Dim MeHwnd As Long
    MeHwnd = FindWindowA(vbNullString, Usf.Caption)
    If MeHwnd > 0 Then
        hSysMenu = GetSystemMenu(MeHwnd, False)
        RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
    Else
        MsgBox "Handle de " & Usf.Caption & " Introuvable", vbCritical
    End If
 
End Sub

[pijaku]

La procédure de suppression de contrôle ne fonctionne pas chez moi.
Voici comment je l'utilises :
Code de la classe Classe1 :

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
        Public Usf As Object
        Private Nom As String
        Private Dico As Object
 
        Public WithEvents Bouton As MSForms.CommandButton
        Public WithEvents Text As MSForms.TextBox
 
        'Initialise la collection
        Private Sub Class_Initialize()
         Set Dico = CreateObject("Scripting.dictionary")
        End Sub
 
        Private Sub NewTxt(Name As String, TxtDefaut As String, Width As Double, Height As Double, Left As Double, Top As Double)
        If Dico.exists(Name) = True Then Exit Sub
        Dim cls As New Classe1
          Set cls.Text = Usf.Controls.Add("forms.Textbox.1")
         Set cls.Usf = Usf
            With cls.Text
                .Name = Name
                .Text = TxtDefaut
                .Width = Width
                .Height = Height
                .Left = Left
                .Top = Top
            End With
           Dico.Add Name, cls
           Set cls = Nothing
        End Sub
        'permet de créer un UserForm
        Private Sub NewUsf(Caption As String, Width As Double, Height As Double)
        Set Usf = ThisWorkbook.VBProject.VBComponents.Add(3)
        Nom = Usf.Name
        VBA.UserForms.Add (Nom)
        Set Usf = UserForms(UserForms.Count - 1)
        With Usf
            .Caption = Caption
            .Width = Width
            .Height = Height
          End With
        End Sub
        'Ouvre le UserForm
        Public Sub Show()
 
        NewUsf "toto", (20 * 2) + 100, (30 * 7) + 5 + (5 * 5)
        NewTxt "TxtBox1", "Bouton", 100, 30, 20, 30 * (1 - 1) + 5
        For I = 2 To 7
          NewBouton "Bouton" & I, "Bouton " & I, 100, 30, 20, 30 * (I - 1) + 5
        Next
        Usf.Show
        End Sub
        'Permet d'ajouter un bouton
        Private Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
        If Dico.exists(Name) = True Then Exit Sub
        Dim cls As New Classe1
          Set cls.Bouton = Usf.Controls.Add("forms.CommandButton.1")
         Set cls.Usf = Usf
            With cls.Bouton
                .Name = Name
                .Caption = Caption
                .Width = Width
                .Height = Height
                .Left = Left
                .Top = Top
            End With
 
           Dico.Add Name, cls
           Set cls = Nothing
 
        End Sub
 
        'permet de supprimer le UserForm
        Private Sub Class_Terminate()
        Dim I As Integer
        Set Dico = Nothing
        If Nom <> "" Then
            Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
            ThisWorkbook.VBProject.VBComponents.Remove VBComp
        End If
        End Sub
        'L'evennement Click Bouton7 ferme le UserForm
        Private Sub Bouton_Click()
        Select Case Bouton.Name
        Case "Bouton7"
            Unload Usf
        Case Else
            SuppBouton Bouton.Name
        End Select
        End Sub
        Private Sub SuppBouton(Nom)
        Usf.Controls.Remove CStr(Nom)
        If Dico.exists(Nom) Then
            Dico.Remove Nom
        End If
        End Sub

Lors d'un clic sur un des boutons de 2 à 6, le contrôle est supprimé de l'userform, mais pas du Dico.
Par ailleurs, si j’inscris dans la procédure SuppBouton : Debug.Print Dico.Count, le résultat est 0.
Peut être est ce que je l'appelle mal?? Code d'appel :

Code :

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

SuppBouton Bouton.Name