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 |