Палач в Excel VBA

Question

Вы могли бы посоветовать, почему, когда я запускаю такую ​​процедуру - 2-ой точно, у меня нет линии формы, появляющейся на экране?В режиме отладки фигуры отображаются.Это терпит неудачу только, когда это работает нормально.Если он выполняется нормально, линия формы для плохой догадки отображается после завершения процедуры.Строка должна появиться, как только дается неправильное предположение.

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

большое спасибо за вашу помощь.Я обнаружил, что на самом деле, чтобы заставить мой код работать, мне просто нужно дать приложению некоторое время - я просто добавил эту строку

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

в свой цикл

    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

Спасибоза предоставленную мне эту подсказку.Не понял бы это без тебя.

Answer 2

Я думаю, что это работает, хотя я признаю, что могут быть некоторые крайние условия, которые я не тестировал (прошло около 30 лет с тех пор, как я играл в игру палача ...)

Я получилизбавиться от переменных области модуля и немного реструктурировать его, чтобы разделить различные функции / действия.

Основная процедура - Hangman, которая:

• ResetGame, котораяочищает рабочий лист и делает формы невидимыми)
• получает ответ из функции inputbox
• Вызывает процедуру PlayGame с параметром Answer.

The *Процедура 1019 * обрабатывает цикл над догадками игрока (с помощью функции GetNextGuess) и завершается, когда ответ правильный, или если пользователь исчерпал все догадки (на основе числа фигур на рабочем листе, при необходимости измените его).).

Важно: я не позволил игроку угадать «букву или слово».Я также разрешаю отменить / выйти из игры, если пользователь не вводит буквы.

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