Quais são as regras desse jogo? As regras são: todos os números dos números secretos são diferentes; se na sua proposta há números iguais aos secretos, nos lugares certos, eles são Touros; se na sua proposta há números iguais aqueles secretos, porém lugares diferentes dos números secretos, são Vacas.
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_NÚMEROS As Byte = 4 Const MAX_TENTATIVAS As Byte = 25 strNb = Número_Secreto(NB_NÚMEROS) Do bytBull = 0: bytCow = 0: lngCpt = lngCpt + 1 If lngCpt > MAX_ESSAIS Then strMsg = "Máximo de tentativas atingido. Sinto muito, perdeu a perdida!": Exit Do strIn = Pergunta(NB_NÚMEROS) If strIn = "Exit Game" Then strMsg = "Usuário abandona": 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 = "Você ganhou em " & lngCpt & " tentaivas!" Else strTemp = strTemp & vbCrLf & "Avec : " & strIn & " ,você tem : " & bytBull & " touros," & bytCow & " vacas." MsgBox strTemp End If Loop While Not boolEnd MsgBox strMsg End Sub Function Número_Secreto(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 Pergunta(NbDigits As Byte) As String Dim boolGood As Boolean, strIn As String, i As Byte, NbDiff As Byte Do While Not boolGood strIn = InputBox("Digite um número (com " & NbDigits & " dígitos)", "Número") 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
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 "Sorteio : " & StrConv(strNumber, vbUnicode) Debug.Print "---------- INÍCIO ------------" 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 "O SORTEIO É : " & StrConv(strNumber, vbUnicode) & " número secreto encontrado: " & 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
Foto: © VBA.