我正在寻找一种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