pijaku

3 petits jeux : Tic-Tac-Toe (morpion) - Pig The Dice (jeu du cochon) - Bulls And Cows (MasterMind)

par

pijaku

, 28/09/2018 à 11h31 (1179 Affichages)

____________________________________________________________________

Bonjour,

Détournons un peu (beaucoup) Excel pour s'amuser avec trois petits jeux.

Le jeu du morpion (Tic-Tac-Toe) :
Une variante du grand classique. Ce jeu se joue seul contre l'ordinateur.
Vous avez la possibilité de tricher et donc de réduire les chances de l'ordi...

Mise en garde : se joue sur la feuille active. Veillez à ne pas y avoir de données !

Pour y jouer, copier-coller le code ci-dessous dans un Module standard et exécuter la Sub Morpion...

Le code :

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
Option Explicit
 
Private Lines(1 To 3, 1 To 3) As String
Private Nb As Byte, Joueur As Byte
Private Gagne As Boolean, Fin As Boolean, Annule As Boolean
 
Sub Morpion()
Dim P As String, CheatMode As Boolean, i&
    columns("C:E").ColumnWidth = 2.43
    columns("C:E").Cells.Clear
    rows("1:200").RowHeight = 16.5
    MsgBox "Vous-avez les X, le pc les O..." & vbCrLf & "Bonne partie"
    InitLines
    printLines Nb
    i = MsgBox("Voulez-vous tricher?", vbYesNo)
    CheatMode = (i <> vbYes)
    Do
        P = QuiJoue
        If P = "Humain" Then
            Call HumainJoue
            Gagne = IsWinner("X")
        Else
            Call OrdiJoue(CheatMode)
            Gagne = IsWinner("O")
            printLines Nb
        End If
        If Not Gagne Then Fin = IsEnd
    Loop Until Gagne Or Fin Or Annule
    If Not Fin And Not Annule Then
        Nb = Nb + 1
        printLines Nb
        MsgBox P & " Gagne !"
    ElseIf Annule Then
        MsgBox "Annulation par l'utilisateur"
    Else
        Nb = Nb + 1
        printLines Nb
        MsgBox "Game Over!"
    End If
End Sub
Sub InitLines(Optional s As String)
Dim i As Byte, j As Byte
    If s = vbNullString Then s = "#"
    Annule = False
    Nb = 0: Joueur = 0
    For i = LBound(Lines, 1) To UBound(Lines, 1)
        For j = LBound(Lines, 2) To UBound(Lines, 2)
            Lines(i, j) = s
        Next j
    Next i
End Sub
Sub printLines(Nb As Byte)
Dim i As Byte, j As Byte, strT As String
   Range("C" & rows.Count).End(xlUp).Offset(1, 0).Value = "Tour n° " & Nb
   Range("C" & rows.Count).End(xlUp).Offset(1, 0).Resize(3, 3).Value = Lines
End Sub
Function QuiJoue(Optional s As String) As String
    If Joueur = 0 Then
        Joueur = 1
        QuiJoue = "Humain"
    Else
        Joueur = 0
        QuiJoue = "Ordi"
    End If
End Function
Sub HumainJoue(Optional s As String)
Dim L As Byte, C As Byte, BienJoue As Boolean
    Do
        L = Application.InputBox("Choix de la ligne", "Numérique uniquement", Type:=1)
        If L = 0 Then
            Annule = True
        Else
            If L > 0 And L < 4 Then
                C = Application.InputBox("Choix de la colonne", "Numérique uniquement", Type:=1)
                If C > 0 And C < 4 Then
                    If Lines(L, C) = "#" And Not Lines(L, C) = "X" And Not Lines(L, C) = "O" Then
                        Lines(L, C) = "X"
                        BienJoue = True
                    End If
                ElseIf C = 0 Then
                    Annule = True
                End If
            End If
         End If
    Loop Until BienJoue Or Annule
End Sub
Sub OrdiJoue(booB As Boolean)
Dim L As Byte, C As Byte, BienJoue As Boolean
    If booB Then
        For L = LBound(Lines, 1) To UBound(Lines, 1)
            For C = LBound(Lines, 2) To UBound(Lines, 2)
                If Lines(L, C) = "#" Then
                    Lines(L, C) = "O"
                    If IsWinner("O") Then
                        Lines(L, C) = "O"
                        Nb = Nb + 1
                        Exit Sub
                    Else
                        Lines(L, C) = "#"
                    End If
                End If
            Next C
        Next L
        For L = LBound(Lines, 1) To UBound(Lines, 1)
            For C = LBound(Lines, 2) To UBound(Lines, 2)
                If Lines(L, C) = "#" Then
                    Lines(L, C) = "X"
                    If IsWinner("X") Then
                        Lines(L, C) = "O"
                        Nb = Nb + 1
                        Exit Sub
                    Else
                        Lines(L, C) = "#"
                    End If
                End If
            Next C
        Next L
    End If
    Randomize Timer
    Do
        L = Int((Rnd * 3) + 1)
        C = Int((Rnd * 3) + 1)
        If Lines(L, C) = "#" And Not Lines(L, C) = "X" And Not Lines(L, C) = "O" Then
            Lines(L, C) = "O"
            BienJoue = True
        End If
    Loop Until BienJoue
End Sub
Function IsWinner(s As String) As Boolean
Dim i As Byte, j As Byte, Ch As String, strTL As String, strTC As String
    Ch = String$(UBound(Lines, 1), s)
    For i = LBound(Lines, 1) To UBound(Lines, 1)
        For j = LBound(Lines, 2) To UBound(Lines, 2)
            strTL = strTL & Lines(i, j)
            strTC = strTC & Lines(j, i)
        Next j
        If strTL = Ch Or strTC = Ch Then IsWinner = True: Exit For
        strTL = vbNullString: strTC = vbNullString
    Next i
    If Not IsWinner Then
        strTL = Lines(1, 1) & Lines(2, 2) & Lines(3, 3)
        strTC = Lines(1, 3) & Lines(2, 2) & Lines(3, 1)
        If strTL = Ch Or strTC = Ch Then IsWinner = True
    End If
End Function
Function IsEnd() As Boolean
Dim i As Byte, j As Byte
    For i = LBound(Lines, 1) To UBound(Lines, 1)
        For j = LBound(Lines, 2) To UBound(Lines, 2)
            If Lines(i, j) = "#" Then Exit Function
        Next j
    Next i
    IsEnd = True
End Function

Le jeu du cochon (jeu de dé : Pig the dice) :
Règles :
À chaque tour, un joueur jette un dé à plusieurs reprises jusqu'à ce que :

soit 1 soit tiré,
ou que le joueur décide de "garder":
- Si le joueur obtient un 1, il ne marque rien et c'est au joueur suivant de jeter le dé,
- Si le joueur obtient un autre nombre, il est ajouté au total de ce tour et le tour du joueur continue.
- Si le joueur choisit de "garder", le total des points du tour est ajouté à son score global, et c'est au joueur suivant de jeter le dé.

Le premier joueur à marquer 100 points ou plus gagne.

Pour y jouer, copier-coller le code ci-dessous dans un Module standard et exécuter la Sub Cochon.

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
Sub Cochon()
Dim Scs() As Byte, Ask As Integer, Np As Boolean, Go As Boolean
Dim cp As Byte, Rd As Byte, NbP As Byte, ScBT As Byte
 
    Const INPTXT As String = "Nombre de joueurs : "
    Const INPTITL As String = "Numérique uniquement"
    Const ROL As String = "Joueur ¤¤¤¤ lance le dé."
    Const MSG As String = "Voulez-vous garder votre score : "
    Const TITL As String = "Total si vous gardez : "
    Const Res As String = "Le dé donne : ¤¤¤¤ points."
    Const ONE As String = "Le dé donne : 1 point. Désolé!" & vbCrLf & "Joueur suivant."
    Const WIN As String = "Le joueur ¤¤¤¤ a gagné le jeu du cochon!"
    Const STW As Byte = 100
 
    Randomize Timer
    NbP = Application.InputBox(INPTXT, INPTITL, 2, Type:=1)
    ReDim Scs(1 To NbP)
    cp = 1
    Do
        ScBT = 0
        Do
            MsgBox Replace(ROL, "¤¤¤¤", cp)
            Rd = Int((Rnd * 6) + 1)
            If Rd > 1 Then
                MsgBox Replace(Res, "¤¤¤¤", Rd)
                ScBT = ScBT + Rd
                If Scs(cp) + ScBT >= STW Then
                    Go = True
                    Exit Do
                End If
                Ask = MsgBox(MSG & ScBT, vbYesNo, TITL & Scs(cp) + ScBT)
                If Ask = vbYes Then
                    Scs(cp) = Scs(cp) + ScBT
                    Np = True
                End If
            Else
                MsgBox ONE
                Np = True
            End If
        Loop Until Np
        If Not Go Then
            Np = False
            cp = cp + 1
            If cp > NbP Then cp = 1
        End If
    Loop Until Go
    MsgBox Replace(WIN, "¤¤¤¤", cp)
End Sub

Version populaire du Mastermind (Bulls and Cows) :
Règles

Tous les chiffres dans le nombre secret sont différents.
Si dans votre proposition il y a des chiffres du nombre secret, aux bons endroits, ce sont des Taureaux.
Si dans votre proposition il y a des chiffres du nombre secret, mais pas aux bons endroits, ce sont des Vaches.

Pour y jouer, copier-coller le code ci-dessous dans un Module standard et exécuter la Sub Bulls_And_Cows.

Le code :

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
Sub Bulls_and_cows()
Dim strNb As String, strIn As String, strMsg As String, strTemp As String
Dim boolEnd As Boolean, CheatMode As Boolean
Dim lngCpt As Long
Dim i As Byte, bytCow As Byte, bytBull As Byte
Const NB_CHIFFRES As Byte = 4
Const MAX_ESSAIS As Byte = 25
    strNb = Nombre_Secret(NB_CHIFFRES)
    If MsgBox("Voulez-vous tricher?", vbYesNo) = vbYes Then MsgBox strNb
    Do
        bytBull = 0: bytCow = 0: lngCpt = lngCpt + 1
        If lngCpt > MAX_ESSAIS Then strMsg = "Maximum d'essais atteind. Désolé partie perdue!": Exit Do
        strIn = Question(NB_CHIFFRES)
        If strIn = "Exit Game" Then strMsg = "Abandon utilisateur": Exit Do
        For i = 1 To Len(strNb)
            If Mid$(strNb, i, 1) = Mid$(strIn, i, 1) Then
                bytBull = bytBull + 1
            ElseIf InStr(strNb, Mid$(strIn, i, 1)) > 0 Then
                bytCow = bytCow + 1
            End If
        Next i
        If bytBull = NB_CHIFFRES Then
            boolEnd = True: strMsg = "Vous gagnez en " & lngCpt & " essai" & IIf(lngCpt = 1, "", "s") & " !"
        Else
            strTemp = strTemp & vbCrLf & "Avec : " & strIn & " ,vous avez : " & bytBull & " taureaux, " & bytCow & " vaches."
            MsgBox strTemp
        End If
    Loop While Not boolEnd
    MsgBox strMsg
End Sub
Function Nombre_Secret(NbDigits As Byte) As String
Dim myColl As New Collection
Dim strTemp As String
Dim bytAlea As Byte
    Randomize
    Do
        bytAlea = Int((Rnd * 9) + 1)
        On Error Resume Next
        myColl.Add CStr(bytAlea), CStr(bytAlea)
        If Err <> 0 Then
            On Error GoTo 0
        Else
            strTemp = strTemp & CStr(bytAlea)
        End If
    Loop While Len(strTemp) < NbDigits
    Nombre_Secret = strTemp
End Function
Function Question(NbDigits As Byte) As String
Dim boolGood As Boolean, strIn As String, i As Byte, NbDiff As Byte
    Do While Not boolGood
        strIn = InputBox("Entrez un nombre (à " & NbDigits & " chiffres)", "Nombre")
        If StrPtr(strIn) = 0 Then strIn = "Exit Game": Exit Do
        If strIn <> "" Then
            If Len(strIn) = NbDigits Then
                NbDiff = 0
                For i = 1 To Len(strIn)
                    If Len(Replace(strIn, Mid$(strIn, i, 1), "")) < NbDigits - 1 Then
                        NbDiff = 1
                        Exit For
                    End If
                Next i
                If NbDiff = 0 Then boolGood = True
            End If
        End If
    Loop
    Question = strIn
End Function