VBA - Jeu Bulls & Cows (Taureaux et vaches)

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, ils sont des Taureaux.
- Si dans votre proposition il y a des chiffres du nombre secret, mais pas aux bons endroits, ils sont des Vaches.
Jeu pour "Humains"
Option Explicit Sub Bulls_and_cows() Dim strNb As String, strIn As String, strMsg As String, strTemp As String Dim boolEnd 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) 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 = Len(strNb) Then boolEnd = True: strMsg = "Vous gagnez en " & lngCpt & " essais!" 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
Jeu joué par ordinateur
Option Explicit Sub Main_Bulls_And_Cows_Player() Dim collSoluces As New Collection, Elem As Variant, Soluce As String Dim strNumber As String, cpt As Byte, P As Byte Dim i As Byte, Bulls() As Boolean, NbBulls As Byte, Cows As Byte, Poss As Long Const NUMBER_OF_DIGITS As Byte = 4 strNumber = CreateNb(NUMBER_OF_DIGITS) Debug.Print "TIRAGE : " & StrConv(strNumber, vbUnicode) Debug.Print "---------- DEBUT ------------" Set collSoluces = CollOfPossibleNumbers Poss = collSoluces.Count For Each Elem In collSoluces Debug.Print "Tentative : " & StrConv(Elem, vbUnicode) NbBulls = 0: Soluce = Elem ReDim Bulls(NUMBER_OF_DIGITS - 1) For i = 1 To NUMBER_OF_DIGITS If IsBull(strNumber, Mid(Elem, i, 1), i) Then Bulls(i - 1) = True: NbBulls = NbBulls + 1 RemoveIfNotBull collSoluces, Mid(Elem, i, 1), i End If Next i Cows = 0 For i = 1 To NUMBER_OF_DIGITS If Not Bulls(i - 1) Then If IsCow(collSoluces, strNumber, Mid(Elem, i, 1), P) Then If Not Bulls(P - 1) Then Cows = Cows + 1 End If End If Next i Poss = collSoluces.Count Debug.Print "Taureaux : " & NbBulls & ", Vaches : " & Cows If Poss = 1 Then Exit For Next Debug.Print "---------- FIN ------------" Debug.Print "LE TIRAGE EST : " & StrConv(strNumber, vbUnicode) & " nombre secret trouvé : " & StrConv(Soluce, vbUnicode) End Sub Function CreateNb(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 CreateNb = strTemp End Function Function CollOfPossibleNumbers() As Collection Dim TempColl As New Collection Dim x As String Dim i As Long Dim Flag As Boolean Dim B As Byte For i = 1234 To 9876 Flag = False For B = 1 To 4 x = CStr(i) If Len(Replace(x, Mid(x, B, 1), "")) < 3 Then Flag = True: Exit For End If Next If Not Flag Then TempColl.Add x, x Next i Set CollOfPossibleNumbers = TempColl End Function Function IsBull(strgNb As String, Digit As String, place As Byte) As Boolean IsBull = (Mid(strgNb, place, 1) = Digit) End Function Function IsCow(C As Collection, strgNb As String, Digit As String, place As Byte) As Boolean If (InStr(strgNb, Digit) > 0) Then IsCow = True: place = InStr(strgNb, Digit) RemoveIfNotCow C, Digit End If End Function Sub RemoveIfNotBull(C As Collection, Digit As String, place As Byte) Dim E As Variant For Each E In C If Mid(E, place, 1) <> Digit Then C.Remove E Next End Sub Sub RemoveIfNotCow(C As Collection, Digit As String) Dim E As Variant For Each E In C If (InStr(E, Digit) = 0) Then C.Remove E Next End Sub
Ce document intitulé « VBA - Jeu Bulls & Cows (Taureaux et vaches) » issu de Comment Ça Marche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.