Hangman in Excel VBA

Question

would you be able to advise why when I run such a procedure - 2nd precisely I have no shape line appearing on the screen? In debugging mode shapes get shown. It only fails when it is run normally. If it is run normally shape line for a bad guess is shown after procedure is finished. The line should appear as soon as the bad guess is given obviously.

Dim sh As Shape
Dim Answer As String
Dim r As Range
Dim chNum As Integer
Dim ChCount As Integer
Dim Guess As String
Dim ShCounter As Integer

Sub HangmanWord()

'Clear Cells with Answer
Range("b1", Range("b1").End(xlToRight)).ClearContents

'Making shapes invisible

For Each sh In Worksheets("Game").Shapes

   sh.Visible = msoFalse

Next sh


'Setting-up the word

Answer = UCase(Application.InputBox("Choose the word", "Hangman Game"))
If Answer = "" Then
MsgBox "You did not type a word"
Exit Sub
Else

ChCount = Len(Answer)
chNum = 0

Do Until chNum = ChCount

    For Each r In Range("b1", Cells(1, ChCount + 1))

        chNum = chNum + 1
        r.Value = Mid(Answer, chNum, 1)
        r.Font.Color = vbWhite

    Next r

Loop

End If

End Sub

Sub GuessingHangman()

'Begin the trial

Do Until UCase(Guess) = Answer

Guess:

Guess = UCase(Application.InputBox("Choose a word or a letter", "Hangman"))
If Guess = "" Then
MsgBox "You did not type a word"
Exit Sub
End If

If Guess = Answer Then
MsgBox "Congrats! You did it!"
Exit Sub

Else

    For Each r In Range("b1", Cells(1, ChCount + 1))

        If Range("b1", Cells(1, ChCount + 1)).Find(Guess) Is Nothing Then
        ShCounter = ShCounter + 1
        Worksheets(1).Shapes(ShCounter).Visible = msoTrue
        GoTo Guess

        ElseIf r.Value = Guess Then
        r.Font.Color = vbBlack

        End If

    Next r
    GoTo Guess

End If

Loop


End Sub

Answer 1

many thanks for your help. I have found out that in fact to make my code work I just need to give the application some time - I just added this line

Application.Wait (Now + TimeValue("00:00:01"))

in my loop

    For Each r In Range("b1", Cells(1, ChCount + 1))

    If Range("b1", Cells(1, ChCount + 1)).Find(Guess) Is Nothing Then
    ShCounter = ShCounter + 1
    Worksheets(1).Shapes(ShCounter).Visible = msoTrue
    Application.Wait (Now + TimeValue("00:00:01"))
    GoTo Guess

    ElseIf r.Value = Guess Then
    r.Font.Color = vbBlack

    End If

Next r
GoTo Guess

Thank you for providing me with this hint. Would not figure out it without you.

Answer 2

I think this is working, though I will admit there may be some edge conditions that I did not test (it's been roughly 30 years since I played a hangman game...)

I've gotten rid of the module-scope variables, and restructured it a bit to compartmentalize the various functions/activities.

The main procedure is Hangman which does:

• ResetGame which clears the worksheet and makes shapes invisible)
• gets the Answer from inputbox function
• Calls the PlayGame procedure with the Answer parameter.

The PlayGame procedure handles the loop over the player's guesses (with the GetNextGuess function), and exits when the answer is correct, or if the user has exhausted all of the guesses (based on # of shapes on the worksheet, modify if needed).

Importantly: I did not allow the player to guess a "letter or a word". I also allow to cancel/quit the game if user does not enter a letter.

Option Explicit

Sub Hangman()
Dim Answer As String
Call ResetGame

Answer = UCase(Application.InputBox("Choose the word", "Hangman Game"))
If Answer = "" Then
    MsgBox "You did not type a word"
    Exit Sub
End If

Call PlayGame(Answer)

End Sub

Private Sub ResetGame()
Dim sh As Shape
With Worksheets("Game")
    .Range("A1:B1").Clear
    .Range("B1").Font.ColorIndex = 3
    For Each sh In .Shapes
        sh.Visible = msoFalse
        DoEvents
    Next sh
End With
End Sub

Private Sub PlayGame(Answer As String)
Dim i As Long
Dim correctGuesses As String
Dim wrongGuesses As Long
Dim thisGuess As String

i = 1
thisGuess = GetNextGuess()
Do While Len(correctGuesses) <= Len(Answer)

    Select Case True
        Case (thisGuess <> Mid(Answer, i, 1))
            ' Player has not correctly guessed the next letter in sequence
            wrongGuesses = wrongGuesses + 1
            Call ShowShape(wrongGuesses)
            DoEvents
        Case Else
            correctGuesses = correctGuesses + thisGuess
            Worksheets("Game").Range("A1").Value = correctGuesses
            i = i + 1
            If (correctGuesses = Answer) Then
                MsgBox "You Win!", vbExclamation
                Exit Do
            End If
    End Select

    If wrongGuesses >= Worksheets("Game").Shapes.Count Then
        'Player has made too many guesses and unable to solve the game
        Worksheets("Game").Range("B1").Value = Answer
        MsgBox "You lose!", vbCritical
        Exit Do
    End If

    ' prompt for the next letter/guess:
    thisGuess = GetNextGuess()
Loop

End Sub

Private Sub ShowShape(index As Long)
    Worksheets("Game").Shapes(index).Visible = msoTrue
    DoEvents
    Worksheets("Game").Shapes(index).Select
End Sub

Private Function GetNextGuess() As String

Dim thisGuess As String
thisGuess = Trim(UCase(Application.InputBox("Choose a letter", "Hangman")))
If Len(Trim(thisGuess)) < 1 Then
    If MsgBox("You did not choose a letter", vbRetryCancel) = vbRetry Then
        thisGuess = GetNextGuess()
    Else
        End
    End If
End If

GetNextGuess = Left(thisGuess, 1)

End Function