Quiz using powerpoint 2007

I am working on a building a quiz using powerpoint 2007.  It is a multiple choice test and will be able to type in your answer in a box.  If they choose the correct answer the explanation is show below and if they choose "incorrect" the correct answer is highlighted and the answer is shown at the bottom of the slide.  The slide will then be identified as "incorrect" at the top of the slide.

At the end of the quiz, it should total number of correct answers and be able to review all "incorrect" slides.

Let me know if this possible.
Who is Participating?
Aaron TomoskySD-WAN SimplifiedCommented:
Yes you can. There are a ton of free templates and sample quizzes available.
I don't normally post a google search but seriously, did you not even try to look this up first?
Tavasan65Author Commented:
Here is code that I found via your link.  But I am having issues and hope you can located my errors.
First it was originally configured for question with 3 possible answers.  I need to increase the selection to 4 possible answers.  I have made corrections where I believe they need to be made.  But the presentation will not execute past the 1st slide.

Attached is the code for you to review.

I hope you can assist.
Const NOOFQS = 3

'Used to manipulated the unicode values of bulleted lists
Const UD_CODE_1 = 111
Const UD_CODE_2 = 8226

Public QNo As Integer
Public ExitFlag As Boolean
Public Qs() As String
Public Choices() As String
Public Ans() As Integer
Public UserAns() As Integer

Sub NextSlide()
' Store the ans for later
'UserAns(QNo - 1) = 1
If QNo < NOOFQS Then
    QNo = QNo + 1
    SlideShowWindows(1).Presentation.Slides("QSlide").Shapes(1).TextFrame.TextRange.Text = Qs(QNo - 1)
    Call StopQuiz
End If
End Sub
Sub PreviousSlide()
Static X As Integer
If QNo > 1 Then
    QNo = QNo - 1
End If
End Sub
Sub StopQuiz(Optional EndType As Boolean = False)
' EndType is used as a boolean Flag to indicate whether the user ran out of time
' or whether it was normal exit
Dim ScoreCard As Integer
Dim Ctr As Integer
ExitFlag = True
With SlideShowWindows(1)
For Ctr = 0 To NOOFQS - 1
    If Ans(Ctr) = UserAns(Ctr) Then ScoreCard = ScoreCard + 1
Next Ctr
If EndType = False Then
    .Presentation.Slides("EndSlide").Shapes("Closing").TextFrame.TextRange.Text = "Your score is : " & ScoreCard & " correct out of " & NOOFQS
    .Presentation.Slides("EndSlide").Shapes("Closing").TextFrame.TextRange.Text = "Sorry!!! Either you ran out of time or you chickened out" _
            & vbCrLf & "Better luck next time." & vbCrLf _
            & "Your score is: " & ScoreCard & " correct out of " & NOOFQS
End If
    .View.GotoSlide (.Presentation.Slides("EndSlide").SlideIndex)
End With
End Sub

Sub StopIt()
Call StopQuiz(True)
End Sub

Sub BeginQuiz()
Dim Ctr As Integer
ReDim UserAns(NOOFQS)
ReDim Choices(NOOFQS, 3)

' All the questions
Qs(0) = "1)What does Narcissistic mean?"
Qs(1) = "2)What does Confidant mean?"
Qs(2) = "3)Black Pearl is a nick name for?"

' Set all user answers to negative
For Ctr = 0 To NOOFQS - 1
UserAns(Ctr) = -1
Next Ctr

' All the choices 3 each for a question
Choices(0, 0) = " Very Vain"
Choices(0, 1) = " Very Sleepy"
Choices(0, 2) = " Indecisive"
Choices(0, 3) = " DAMN"

Choices(1, 0) = " Excessive Pride"
Choices(1, 1) = " Trusted Friend"
Choices(1, 2) = " Secret"

Choices(2, 0) = " Mohammed Ali"
Choices(2, 1) = " Pele"
Choices(2, 2) = " George Foreman"

' Provide the answer list here.
' Ans(0) = 0 means that the correct answer to the 1st question is the 1st choice.
' Ans(1) = 1 means that the correct answer to the 2nd question is the 2nd choice.
' Ans(2) = 1 means that the correct answer to the 3rd question is the 2nd choice.

Ans(0) = 0
Ans(1) = 1
Ans(2) = 1

QNo = 1

With SlideShowWindows(1)
    .View.GotoSlide (.Presentation.Slides("QSlide").SlideIndex)
End With
' Comment the line below to stop the timer.
' Call Tmr
End Sub

Sub SetBulletUnicode(ShapeName As String, Code As Integer)
With SlideShowWindows(1).Presentation.Slides("QSlide").Shapes(ShapeName).TextFrame.TextRange.ParagraphFormat.Bullet
        .UseTextFont = msoTrue
        .Character = Code
End With
End Sub
Sub ButtonChoice1()
UserAns(QNo - 1) = 0
End Sub
Sub ButtonChoice2()
UserAns(QNo - 1) = 1
End Sub
Sub ButtonChoice3()
UserAns(QNo - 1) = 2
End Sub
Sub ButtonChoice4()
UserAns(QNo - 1) = 3
End Sub

Sub Tmr()

'Just in the eventuality that you click the start button twice
'isRunning stores the current state of the macro
'TRUE = Running; FALSE = Idle
ExitFlag = False
Static isRunning As Boolean
If isRunning = True Then
    isRunning = True
    Dim TMinus As Integer
    Dim xtime As Date
    xtime = Now

    With ActivePresentation.Slides(2).Shapes("Timer")

    'Countdown in seconds
    TMinus = 59

    Do While (TMinus > -1)
        ' Rather crude way to determine if a second has elapsed
        If ExitFlag = True Then
            .TextFrame.TextRange.Text = "00:00:00"
            isRunning = False
            Exit Sub
        End If
        If Format(Now, "ss") <> Format(xtime, "ss") Then
            xtime = Now

           .TextFrame.TextRange.Text = Format(TimeValue(Format(Now, "hh:mm:ss")) - _
                               TimeSerial(Hour(Now), Minute(Now), Second(Now) + TMinus), "hh:mm:ss")
            TMinus = TMinus - 1
            ' Let the display refresh itself
        End If
    End With
    Debug.Print "came here"
    isRunning = False
    StopQuiz True
End If
End Sub
Sub AssignValues()
    SetBulletUnicode "Choice1", UD_CODE_1
    SetBulletUnicode "Choice2", UD_CODE_1
    SetBulletUnicode "Choice3", UD_CODE_1
    SetBulletUnicode "Choice4", UD_CODE_1

    Select Case UserAns(QNo - 1)
    Case 0
        SetBulletUnicode "Choice1", UD_CODE_2
    Case 1
        SetBulletUnicode "Choice2", UD_CODE_2
    Case 2
        SetBulletUnicode "Choice3", UD_CODE_2
    Case 3
        SetBulletUnicode "Choice4", UD_CODE_2
    End Select
    With SlideShowWindows(1).Presentation.Slides("QSlide")
        .Shapes(1).TextFrame.TextRange.Text = Qs(QNo - 1)
        .Shapes("Choice1").TextFrame.TextRange.Text = Choices(QNo - 1, 0)
        .Shapes("Choice2").TextFrame.TextRange.Text = Choices(QNo - 1, 1)
        .Shapes("Choice3").TextFrame.TextRange.Text = Choices(QNo - 1, 2)
        .Shapes("Choice4").TextFrame.TextRange.Text = Choices(QNo - 1, 3)
    End With
End Sub
Sub ShowAnswers()
Dim AnsList As String
AnsList = "The answers are as follows:" & vbCrLf
For X = 0 To NOOFQS - 1
    AnsList = AnsList & Qs(X) & vbTab & " Answer:" & Choices(X, Ans(X)) & vbCrLf
Next X
MsgBox AnsList, vbOKOnly, "Correct answers"
End Sub

Open in new window

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.