Comment réunir UserForm et Module de classe en un seul module exportable?

Invité · 23/04/2015, 18h36

En soit je ne pense pas que ce soit un problème d'utiliser le tag du userForm!
Ce qui est important c'est de retourner usf.Value sub test.

Tu peux remplacer la méthode show par une fonction value qui elle retournera le tag du Userform.
Bien sur l'événement click donnera la valeur au tag et placera le usf à Hed.

A charge a sub test de décharger l'usf (Unload) qui lui est public dans la classe!

Remarques la fonction Value peut bien charger et décharger le Usf!

**pijaku** · 24/04/2015, 07h28

Bonjour,

Ce projet touche à sa fin.
J'aurais encore besoin d'un éclaircissement. Qu'entends tu par :

placera le usf à Hed

Ne restera donc :
- qu'à parer l'éventualité que l'utilisateur n'ait pas coché la case "Accès approuvé au modèle d'objet du projet VBA".
Pour cela, je pense qu'une simple gestion d'erreur devrait le faire.
- tester l'utilisation éventuelle de contrôles supplémentaires.
et optionnellement :
- Ajouter de manière automatique les références : http://www.developpez.net/forums/d14...er-references/

Invité · 24/04/2015, 07h51

Bonjour,
Oui mais je pense qu'il est possible par programme, mais chacun ses lacunes et j'ai les miennes!

En tout cas je ne sais pas ce que tu connaissais en programmation Object mais j'espère t'avoir fait progresser!

**pijaku** · 24/04/2015, 08h06

En tout cas je ne sais pas ce que tu connaissais en programmation Object mais j'espère t'avoir fait progresser!

Tu ne t'en es peut être pas aperçu, mais cette discussion avec toi et Pierre m'a fait faire un bond en avant.
Merci.

Je vais bricoler un exemple complet et reviendrais le placer ici.
A ce moment, je considérerais cette discussion comme "résolue".
Mais il faudra patienter un peu, j'ai d'autres projets sur le feu qui ne peuvent plus attendre.

Merci encore à vous deux, aux autres participants et à tous les lecteurs (nombreux) de cette discussion.

A bientôt avec un exemple donc de "couteau-suisse"...

Invité · 24/04/2015, 08h40

je me suis trompé c'est Hide masque le UserForm et rend la mains à la fonction Value!

Code :

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

Usf.Hide

Code Classe1 :

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
#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
Public Dico As Object
Public TypeObjet As String
Public WithEvents Bouton As MSForms.CommandButton
Public WithEvents Text As MSForms.TextBox
Public WithEvents FRM As MSForms.Frame
Public WithEvents MultiPage As MSForms.MultiPage
 
 
Private Function NewControl(Controle As String, Page As Integer)
If Dico.EXISTS(Name) = True Then NewControl = Nothing: Exit Function
 Select Case TypeObjet
    Case "UserForm"
        Set NewControl = Usf.Controls.Add(Controle)
    Case "Frame"
        Set NewControl = FRM.Controls.Add(Controle)
    Case "MultiPage"
        Set NewControl = MultiPage(Page).Add(Controle)
    End Select
End Function
'Initialise la collection
Private Sub Class_Initialize()
 Set Dico = CreateObject("Scripting.dictionary")
End Sub
Public Sub NewTxt(Name As String, TxtDefaut As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.Textbox.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
Dim cls As New Classe1
  Set cls.Text = obj
 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)
 TypeObjet = "UserForm"
With Usf
    .Caption = Caption
    .Width = Width
    .Height = Height
  End With
 
End Sub
'Ouvre le UserForm
Public Sub Show()
 
NewUsf "toto", (120 * 2) + 100, (30 * 7) + 5 + (5 * 5)
NewFrme "Fram1", "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3
NewMulitPage "MulitPage1", "toto", (110 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, 7, 0, "Bouton 1", "Bouton 2", "Bouton 3", "Bouton 4", "Bouton 5", "Bouton 6", "Bouton 7"
 
For I = 1 To 7
    Dico("MulitPage1").NewFrme "Fram" & I, "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, I - 1
  Dico("MulitPage1").Dico("Fram" & I).NewBouton "Bouton" & I, "Bouton " & I, 100, 30, 20, 30 * 5
Next
Usf_Initialize
Usf.Show
End Sub
Public Function Value()
 
NewUsf "toto", (120 * 2) + 100, (30 * 7) + 5 + (5 * 5)
NewFrme "Fram1", "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3
NewMulitPage "MulitPage1", "toto", (110 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, 7, 0, "Bouton 1", "Bouton 2", "Bouton 3", "Bouton 4", "Bouton 5", "Bouton 6", "Bouton 7"
 
For I = 1 To 7
    Dico("MulitPage1").NewFrme "Fram" & I, "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, I - 1
  Dico("MulitPage1").Dico("Fram" & I).NewBouton "Bouton" & I, "Bouton " & I, 100, 30, 20, 30 * 5
Next
Usf_Initialize
Usf.Show
Value = Usf.Tag
Unload Usf
End Function
Public Sub NewMulitPage(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Nb As Integer, Page As Integer, ParamArray Onglets())
Dim obj
Set obj = NewControl("forms.MultiPage.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
 Dim cls As New Classe1
 
 Set cls.Usf = Usf
  Set cls.MultiPage = obj
 
   n = cls.MultiPage.Pages.Count
  n = Nb - n
 For I = 1 To n
    cls.MultiPage.Pages.Add
  Next
  For I = 0 To UBound(Onglets)
   cls.MultiPage.Pages(I).Caption = CStr(Onglets(I))
  Next
    cls.TypeObjet = "MultiPage"
 
    With cls.MultiPage
        .Name = Name
        '.Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub
Public Sub NewFrme(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.frame.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
 Dim cls As New Classe1
 Set cls.Usf = Usf
  Set cls.FRM = obj
    cls.TypeObjet = "Frame"
 
    With cls.FRM
        .Name = Name
        .Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub
'Permet d'ajouter un bouton
Public Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.CommandButton.1", Page)
If obj = True Then Exit Sub
 Dim cls As New Classe1
 Set cls.Usf = Usf
 Set cls.Bouton = obj
    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()
Usf.Tag = Bouton.Caption
Usf.Hide
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
Sub test()
Dim Usf As New Classe1
MsgBox Usf.Value
Set Usf = Nothing
End Sub

**pijaku** · 24/04/2015, 10h40

Superbe.
Rien à dire sur ce code, si ce n'est...
Un truc me tarabuste depuis le début. Je ne t'en ai pas parlé parce que ça n'avait pas d'intérêt.
Dans ton module de classe tu fais appel aux api's windows :

Code :

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

1
2
3
4
5
#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

Or tu fais référence 2 fois à FindWindowA.
Ton VBA ne bloque pas ça?
Moi j'ai une belle alerte : Nom ambigüe détecté...
Ou alors tu codes le tout en direct sur le forum... (et ça, c'est épatant!)

Invité · 24/04/2015, 10h48

oui effectivement il y en à une de trop!
mois je suis en 32 bits donc pas de problème j'ai pas vu!
si tu regardes le #else

Ou alors tu codes le tout en direct sur le forum... (et ça, c'est épatant!)

ça m'arrive mais là!

à vrai dire oui

**pijaku** · 04/05/2015, 11h06

Bonjour,

Je reviens ici suite à une difficulté...
Je parviens bien, lors d'un clic sur un des boutons, à boucler sur tous les contrôles de la forme par le code suivant :

Code :

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

1
2
3
4
5
6
7
Private Sub Bouton_Click()
Dim Ctrl As Control
 
For Each Ctrl In maForm.Controls
    Debug.Print Ctrl.Name
Next
End Sub

Par contre, ce que je souhaiterais, c'est de boucler sur toutes les instances de la classe plutôt que sur les contrôles.*
Comment faire cela?

Code :

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

1
2
3
4
5
6
7
Private Sub Bouton_Click()
Dim Ctrl As Classe1
 
'For Each Ctrl In ???
    'Set Ctrl = ??? 'Dico(machin).Item(truc)???
'Next
End Sub

* je ne sais pas si c'est termes sont très académiques donc, en cas de doute, n'hésitez pas à me relancer...

Invité · 04/05/2015, 12h10

Bonjour,
tu peux définir un DicoParent dans le module de classe ce qui te permet de remonter d'un cran dans la hiérarchie.
tu peux déclarer public Usf as classe1 dans la zone declarative de ton module standard.

perso j'utiliserai Usf de l'instance mais c'est toi qui voies!

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
If VBA7 Then
    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
Public Dico As Object
Public DicoParent As Object
Public TypeObjet As String
Public WithEvents Bouton As MSForms.CommandButton
Public WithEvents Text As MSForms.TextBox
Public WithEvents FRM As MSForms.Frame
Public WithEvents MultiPage As MSForms.MultiPage
 
 
Private Function NewControl(Controle As String, Page As Integer)
If Dico.EXISTS(Name) = True Then NewControl = Nothing: Exit Function
 Select Case TypeObjet
    Case "UserForm"
        Set NewControl = Usf.Controls.Add(Controle)
    Case "Frame"
        Set NewControl = FRM.Controls.Add(Controle)
    Case "MultiPage"
        Set NewControl = MultiPage(Page).Add(Controle)
    End Select
End Function
'Initialise la collection
Private Sub Class_Initialize()
 Set Dico = CreateObject("Scripting.dictionary")
End Sub
Public Sub NewTxt(Name As String, TxtDefaut As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.Textbox.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
Dim cls As New Classe1
  Set cls.Text = obj
 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)
 TypeObjet = "UserForm"
With Usf
    .Caption = Caption
    .Width = Width
    .Height = Height
  End With
 
End Sub
'Ouvre le UserForm
Public Sub Show()
 
NewUsf "toto", (120 * 2) + 100, (30 * 7) + 5 + (5 * 5)
NewMulitPage "MulitPage1", "toto", (110 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, 7, 0, "Bouton 1", "Bouton 2", "Bouton 3", "Bouton 4", "Bouton 5", "Bouton 6", "Bouton 7"
Set Dico("MulitPage1").DicoParent = Dico
For I = 1 To 7
    Dico("MulitPage1").NewFrme "Fram" & I, "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, I - 1
    set Dico("MulitPage1").Dico("Fram" & I).DicoParent = Dico("MulitPage1").Dico
    Dico("MulitPage1").Dico("Fram" & I).NewBouton "Bouton" & I, "Bouton " & I, 100, 30, 20, 30 * 5
   set  Dico("MulitPage1").Dico("Fram" & I).Dico("Bouton" & I).DicoParent = Dico("MulitPage1").Dico("Fram" & I).Dico
 
Next
Usf_Initialize
Usf.Show
End Sub
Public Function Value()
 
NewUsf "toto", (120 * 2) + 100, (30 * 7) + 5 + (5 * 5)
NewFrme "Fram1", "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3
NewMulitPage "MulitPage1", "toto", (110 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, 7, 0, "Bouton 1", "Bouton 2", "Bouton 3", "Bouton 4", "Bouton 5", "Bouton 6", "Bouton 7"
 
For I = 1 To 7
    Dico("MulitPage1").NewFrme "Fram" & I, "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, I - 1
  Dico("MulitPage1").Dico("Fram" & I).NewBouton "Bouton" & I, "Bouton " & I, 100, 30, 20, 30 * 5
Next
Usf_Initialize
Usf.Show
Value = Usf.Tag
Unload Usf
End Function
Public Sub NewMulitPage(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Nb As Integer, Page As Integer, ParamArray Onglets())
Dim obj
Set obj = NewControl("forms.MultiPage.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
 Dim cls As New Classe1
 
 Set cls.Usf = Usf
  Set cls.MultiPage = obj
 
   n = cls.MultiPage.Pages.Count
  n = Nb - n
 For I = 1 To n
    cls.MultiPage.Pages.Add
  Next
  For I = 0 To UBound(Onglets)
   cls.MultiPage.Pages(I).Caption = CStr(Onglets(I))
  Next
    cls.TypeObjet = "MultiPage"
 
    With cls.MultiPage
        .Name = Name
        '.Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub
Public Sub NewFrme(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.frame.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
 Dim cls As New Classe1
 Set cls.Usf = Usf
  Set cls.FRM = obj
    cls.TypeObjet = "Frame"
 
    With cls.FRM
        .Name = Name
        .Caption = Caption
        .Width = Width
        .Height = Height
        .Left = Left
        .Top = Top
    End With
 
   Dico.Add Name, cls
   Set cls = Nothing
End Sub
'Permet d'ajouter un bouton
Public Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.CommandButton.1", Page)
If obj = True Then Exit Sub
 Dim cls As New Classe1
 Set cls.Usf = Usf
 Set cls.Bouton = obj
    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()
Usf.Tag = Bouton.Caption
Usf.Hide
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** · 04/05/2015, 12h47

Bonjour,

Merci à toi rdurupt.
J'avais pensé effectivement à créer une collection (ou en l’occurrence ici un dico) pour regrouper les instances relatives à mes boutons, mais n'y étais pas parvenu.
Cela semble plus clair en voyant ton code (c'est souvent le cas lorsqu'on a la solution sous le nez...).

Pourrais tu préciser ce que tu entends par

perso j'utiliserai Usf de l'instance mais c'est toi qui voies!

Merci encore.

Invité · 04/05/2015, 13h27

la solution que tu as précisé dans ton post, après tout c'est un UserForm!

Code :

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

1
2
3
4
5
6
7
Private Sub Bouton_Click()
Dim Ctrl As Control
 
For Each Ctrl In maForm.Controls
    Debug.Print Ctrl.Name
Next
End Sub

rappel toi nous passont le userForm à toute les instance!

Code :

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

1
2
3
Dim cls As New Classe1
 
 Set cls.Usf = Usf

**pijaku** · 04/05/2015, 13h43

Oui. C'est ce que je ferais dans tous les cas de figure car d'une simplicité à toute épreuve.
Mais pas ici, puisque je prends ce sujet pour un exercice, autant que j'aille au bout des choses.
Merci.
J'ai essayé ton DicoParent, c'est une tuerie.
Efficace, vraiment.
Merci encore.
Comme promis, je reviendrais avec un exemple concret, dès que j'en aurais terminé.
C'est en très bonne voie. Ne me manque plus qu'une petite gymnastique récursive à terminer...
Grrr.

**pijaku** · 05/05/2015, 10h23

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

Comment réunir UserForm et Module de classe en un seul module exportable?

Macros et VBA Excel

Discussions similaires

Partager

Partager