PowerPoint中允许再次尝试错误答案的VBA循环

我正在寻找一个VBA方法，允许在PowerPoint中的多项选择测验中多次尝试（两次尝试）。我也想给测验打分，但第二次尝试提问只得0.5分。第二次尝试后，我希望测验继续到下一张幻灯片。任何帮助都将不胜感激。谢谢

Option Explicit

Dim userid
Dim numbercorrect
Dim numberwrong
Dim abunny
Dim acheetah
Dim akoala
Dim slidemove1

Sub start()
numbercorrect = 0
numberwrong = 0
End Sub

Sub hint1()
MsgBox ("It is usually grey in colour.")
End Sub

Sub name()
userid = InputBox(Prompt:="What is your name?")
start
ActivePresentation.SlideShowWindow.View.Next
End Sub


Sub correct()
MsgBox ("well done! " & userid)
addcorrectanswer
ActivePresentation.SlideShowWindow.View.Next
End Sub

Sub incorrect()
MsgBox ("Sorry that's wrong! " & userid)
addwronganswer
ActivePresentation.SlideShowWindow.View.Next
End Sub

Sub hint2()
MsgBox ("Its not rainbow ;)")
End Sub

Sub hint3()
MsgBox (" It is faster than 30mph")
End Sub

Sub addcorrectanswer()
numbercorrect = numbercorrect + 1
End Sub

Sub addwronganswer()
numberwrong = numberwrong + 1
End Sub

Sub finalscore()
MsgBox ("You scored " & Round(100 * numbercorrect / (numbercorrect + numberwrong), 2) & "%")
End Sub

Function AskQuestion(qPrompt As String, qAnswers As String) As String
    Dim qReply As String
    Dim numAttempts As Integer ' keeps track of number of attempts left
    Dim score As Double        ' keeps track of what score is given for correct answer
    numAttempts = 2
    score = 1
    'Create a loop that keeps going until they get it right
    'or they have no more attempts left
    Do
        qReply = InputBox(Prompt:=qPrompt)
        'Check if the users reply exists in our list of replies
        '(Use "LCase" so that we don't have to include all possible
        ' case variations in our list of valid replies, and "Trim" to
        ' get rid of any leading/trailing spaces)
        If InStr("|" & qAnswers & "|", Trim(LCase(qReply))) > 0 Then
            MsgBox "well done! " & userid
            numbercorrect = numbercorrect + score
            ' because we only have "numbercorrect" and "numberwrong" variables
            ' rather than "numbercorrect" and "numberquestions" variables,
            ' we need to adjust "numberwrong" to get the total questions right
            numberwrong = numberwrong + 1 - score
            'If they are correct, exit the loop
            Exit Do
        ElseIf numAttempts > 1 Then
            ' If not the last permitted attempt, just tell them to try again
            MsgBox "Sorry that's wrong! " & userid & vbCrLf & "Please try again."
            ' reduce how many attempts remaining
            numAttempts = numAttempts - 1
            ' change score they will get if they get it right next time
            score = 0.5
        Else
            MsgBox "Sorry that's wrong! " & userid
            numberwrong = numberwrong + 1
            'If they are incorrect, and have no more attempts, exit the loop
            Exit Do
        End If
    Loop
    ActivePresentation.SlideShowWindow.View.Next
    ' return the value entered by the user so that it can be placed
    ' in "abunny", "acheetah" and "akoala" variables
    AskQuestion = qReply
End Function

Sub qbunny()
    abunny = AskQuestion("What is a baby Rabbit called?", "kit")
    With SlideShowWindows(1).View
        .gotoslide 12
    End With
End Sub

Sub qcheetah()
    acheetah = AskQuestion("How fast can a cheetah run?in mph", "60mph|60 mph")
    With SlideShowWindows(1).View
        .gotoslide 12
    End With

End Sub


Sub qkoala()
    akoala = AskQuestion("Is a koala part of the bear family?", "no")
    With SlideShowWindows(1).View
        .gotoslide 12
    End With

End Sub

Sub gotoslide1()

With SlideShowWindows(1).View
.gotoslide 3
End With
End Sub

Sub gotoslide2()

With SlideShowWindows(1).View
.gotoslide 6
End With
End Sub

Sub gotoslide3()

With SlideShowWindows(1).View
.gotoslide 9
End With
End Sub