pijaku

________________________________________________


Bonjour,

Pas de blabla, du résul... Euh non, du code !

Aujourd'hui, un petit démineur sous UserForm.
Vous aurez besoin :
> d'un module de classe nommé : ClassDemineur
> d'un module standard.

ATTENTION :
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
Et : "accès approuvé au modèle objet du projet VBA" doit être cochée dans les options Excel.

Code du module de Classe :

Code vba :

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
259
260
261
262
263
264
265
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 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 ClassDemineur                                 '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 = &HFFFFFF             '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 ClassDemineur()                           'propriété de type tableau
'propriété Voisins en Lecture
   Voisins = cVoisins
End Property
 
Property Let Voisins(ByRef nouvVoisins() As ClassDemineur)
'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
   On Error GoTo 0
   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
      Case Else: Exit Sub
   End Select
   NbMines = (NbLignes * NbColonnes) * Difficult \ 100
   ReDim MineAdress(NbMines)
   For CptMine = 1 To NbMines                 'coordonnées des Mines : Col-Lig
      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
         'les noms des boutons : Col-Lig
         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.Tag = Timer  'stockage de l'heure de début de partie dans la propriété Tag de l'userform
   maForm.Show         'affichage du démineur
   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
   Set maForm = ThisWorkbook.VBProject.VBComponents.Add(3)  'on ajoute au projet un module d'userform
   Nom = maForm.Name                                        'on prend son nom
   VBA.UserForms.Add (Nom)                                  'on ajoute l'userform au projet VBA
   Set maForm = UserForms(UserForms.Count - 1)              'on affecte cet userform à notre variable objet
   With maForm                                              'on lui affecte certaines propriétés
      .Caption = Titre                                      'titre
      .Width = Largeur                                      'largeur
      .Height = Hauteur                                     '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              'si déjà existant on quitte
   Dim maClass As New ClassDemineur                             'création d'une nouvelle instance de notre classe
   Set maClass.Fram = maForm.Controls.Add("forms.frame.1")  'Création d'un contrôle de type Frame
   Set maClass.maForm = maForm         'on affecte l'userform à la propriété "maForm" de notre instance de classe
   With maClass.Fram                   'on lui affecte certaines propriétés
      .Name = monNom                   'nom
      .Caption = Titre                 'titre
      .Move 0, 0, Largeur, Hauteur     'emplacement
   End With
   Dico.Add monNom, maClass            'on ajoute notre instance de classe au Dico
   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                       'si déjà existant on quitte
   Dim maClass As New ClassDemineur                                      'création d'une nouvelle instance de notre classe
   Set maClass.Bouton = Fram.Controls.Add("forms.CommandButton.1")   'Création d'un contrôle de type Bouton
   Set maClass.maForm = maForm         'on affecte l'userform à la propriété "maForm" de notre instance de classe
   maClass.Mine = boolMine             'on définit la propriété Mine de notre bouton (True ou False)
   With maClass.Bouton                 'on définit certaines propriétés du bouton
      .Name = monNom                            'son nom
      .Caption = Titre                          'son Caption
      .Move Gauche, Haut, LARG_BTN, LARG_BTN    'son emplacement
      If ModeTriche Then                           'EN MODE TRICHE, COLORE LES BOUTONS MINES
         If boolMine Then .BackColor = COUL_MINE Else .BackColor = COUL_BOUTON
      Else
         .BackColor = COUL_BOUTON
      End If
   End With
   Dico.Add monNom, maClass            'on ajoute notre instance de classe au Dico
   Set maClass = Nothing
End Sub
 
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
      clic = clic + 1                                                            'incrémentation du compteur de clics gauches
      maForm.Caption = "Démineur - Nombre de coups joués : " & clic              'inscription du nombre de coups joués
      If DicoParent.Item(Bouton.Name).Mine Then                                  'si bouton miné
         Call Affiche_Toutes_Mines                                               'affichage de toutes les mines
         MsgBox "Partie perdue"                                                  'message PERDU !
         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 ClassDemineur                                                '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                                                         'lance la fonction Partie_Gagnee
      Call Affiche_Toutes_Mines                                                  'si victoire : affichage des mines et message:
      MsgBox "Félicitations" _
                & vbCrLf & "Partie Gagnée en : " & CInt(Timer - CDbl(maForm.Tag)) & " secondes." _
                & vbCrLf & "et en : " & clic & " coups joués.", vbOKOnly + vbExclamation, "GAGNE!"
      maForm.Hide                   'on quitte l'userform. Cela déclenche le destructeur de la classe
   End If
End Sub
 
Private Sub Affiche_Toutes_Mines()
'En cas de partie perdue, colore tous les boutons minés
   Dim cle
   For Each cle In DicoParent.keys 'boucle sur toutes les clés de notre DicoParent
   'celui-ci contient toutes les instances de la classe contenues dans le Frame
      'si l'instance de classe est minée => coloriage
      If DicoParent.Item(cle).Mine Then DicoParent.Item(cle).Bouton.BackColor = COUL_MINE
   Next
End Sub
 
Private Sub Demine(Cl As ClassDemineur)
'procédure récursive de propagation de la découverte des boutons non minés
   Dim NbMines As Integer
   NbMines = CompteMines(Cl.Bouton.Name)  'on teste le nombre de mines voisines
   If NbMines > 0 Then                    'si le bouton a au moins une mine parmi ses voisins
      Cl.Bouton.Caption = NbMines         'on affiche ce nombre de mines
      Cl.Decouverte = True                'on découvre ce bouton
   Else                                   'sinon
      If Cl.Decouverte = False Then       'Si le bouton n'est pas déjà découvert
         Cl.Decouverte = True             'on le découvre
         Cl.Bouton.Visible = False        'on rend la découverte visible par le joueur (=> le bouton disparait)
         Quels_Voisins Cl                 'on cherche qui sont les boutons voisins de ce bouton
         Dim tb() As ClassDemineur, i As Integer
         tb = Cl.Voisins
         For i = 0 To UBound(tb)          'on démine tous les boutons voisins (RECURSIVITE)
            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 ClassDemineur
   For i = -1 To 1               'en incrémentant la colonne et la ligne de -1 à 1 on ne "vise" que les
      For j = -1 To 1            'boutons voisins de celui dont le nom est passé en paramètre
         Col = CInt(Split(Bout, "-")(0)) + i                   'incrémentation n° de colonne
         Lig = CInt(Split(Bout, "-")(1)) + j                   'incrémentation n° de ligne
         If DicoParent.Exists(Col & "-" & Lig) Then            'si le bouton existe (évite l'erreur de "débord" de l'userform)
            Set maClass = DicoParent.Item(Col & "-" & Lig)     'on attribue à notre variable le bouton voisin
            If maClass.Mine Then CompteMines = CompteMines + 1 's'il est miné on incrémente notre fonction de 1
         End If
      Next j
   Next i
End Function
 
Private Sub Quels_Voisins(Cl As ClassDemineur)
'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 ClassDemineur, ListeVoisins() As ClassDemineur, cpt As Byte
   For i = -1 To 1               'en incrémentant la colonne et la ligne de -1 à 1 on ne "vise" que les
      For j = -1 To 1            'boutons voisins de celui dont le nom est passé en paramètre
         Col = CInt(Split(Cl.Bouton.Name, "-")(0)) + i      'incrémentation n° de colonne
         Lig = CInt(Split(Cl.Bouton.Name, "-")(1)) + j      'incrémentation n° de ligne
         'si le bouton existe et que son nom est différent de celui passé en paramètre (on n'est pas son propre voisin ;-)
         If DicoParent.Exists(Col & "-" & Lig) And Cl.Bouton.Name <> Col & "-" & Lig Then
            Set maClass = DicoParent.Item(Col & "-" & Lig)  'on attribue à notre variable le bouton voisin
            ReDim Preserve ListeVoisins(cpt)                'redimensionnement variable tableau
            Set ListeVoisins(cpt) = maClass                 'on affecte notre instance de classe (bouton) au tableau
            cpt = cpt + 1
         End If
      Next j
   Next i
   Cl.Voisins = ListeVoisins        'on affecte la propriété Voisins de notre instance de classe (de notre bouton)
End Sub
 
Private Function Partie_Gagnee() As Boolean
   Dim cle
   Partie_Gagnee = False
   For Each cle In DicoParent.keys 'boucle sur toutes les clés de notre DicoParent
   '(donc sur toutes les instances de la classe, donc sur tous les boutons)
      'Si le bouton n'est pas "découvert" et qu'il ne contient pas de mine
      If DicoParent.Item(cle).Decouverte = False And DicoParent.Item(cle).Mine = False Then
         'alors la partie n'est pas finie
         Exit Function
      End If
   Next
   Partie_Gagnee = True
End Function
 
Private Function EstDans(adresse As String, tb) As Boolean
'fonction de recherche d'une valeur dans une var tableau
   Dim i As Long
   EstDans = False
   For i = 0 To UBound(tb) 'boucle sur toute la variable tableau passée en paramètre
      If tb(i) = adresse Then EstDans = True: Exit Function 'si on trouve l'élément cherché => fonction vraie, on sort
   Next i
End Function
 
Private Sub Class_Terminate()
'destructeur de la classe cDémineur
   Dim VBComp 'As VBComponent
   Set Dico = Nothing            'supprime toutes les instances de notre classe => tous les boutons
   If Nom <> "" Then             's'il s'agit de l'userform (seule instance ayant une propriété "Nom" remplie)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom) 'on le cible
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     'on le supprime
   End If
End Sub

Code d'appel dans le module standard :

Code vba :

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
Option Explicit
Public clic As Long
 
Sub Demineur()
  Dim MyForm As New ClassDemineur
  Dim rep As Integer, niveau As Long, Flag As Boolean
 
  clic = 0
  rep = MsgBox("Débutant ?", vbYesNo + vbQuestion, "Choix du niveau")
  If rep = vbYes Then
    niveau = 0
  Else
    rep = MsgBox("Intermédiaire ?", vbYesNo + vbQuestion, "Choix du niveau")
    niveau = IIf(rep = vbYes, 1, 2)
  End If
  'Flag = IIf(Feuil1.Range("A1") = "triche", True, False)
  MyForm.Show niveau, True
End Sub

Les deux paramètres passés à la classe déterminent la difficulté (niveau) et si le Cheat Mode est activé (ModeTriche = True)...

Bon jeu, et à ++
Franck