Menu

VBA - Jogo Bulls & Cows (Touros e Vacas)

Última modificação: por Pedro Muxfeldt .


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.

Jogo para pessoas

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

Jogo para computadores

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.

Nosso conteúdo é produzido em colaboração com especialistas em tecnologia da informação sob o comando de Jean-François Pillou, fundador do CCM.net. CCM é um site sobre tecnologia líder em nível internacional e está disponível em 11 idiomas.
Este documento, intitulado 'VBA - Jogo Bulls & Cows (Touros e Vacas) ', está disponível sob a licença Creative Commons. Você pode copiar e/ou modificar o conteúdo desta página com base nas condições estipuladas pela licença. Não se esqueça de creditar o CCM (br.ccm.net) ao utilizar este artigo.
VBA - Estruturas condicionais (if e outros testes)
VB6 - Imprimir um quadro Acces em um FlexGrid VB6

Assine nossa newsletter!
Assine nossa newsletter!
Junte-se à comunidade