Quiz using powerpoint 2007

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)
    AssignValues
Else
    Call StopQuiz
End If
DoEvents
End Sub
Sub PreviousSlide()
Static X As Integer
If QNo > 1 Then
    QNo = QNo - 1
    AssignValues
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
Else
    .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 Qs(NOOFQS)
ReDim Ans(NOOFQS)
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
AssignValues

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
AssignValues
End Sub
Sub ButtonChoice2()
UserAns(QNo - 1) = 1
AssignValues
End Sub
Sub ButtonChoice3()
UserAns(QNo - 1) = 2
AssignValues
End Sub
Sub ButtonChoice4()
UserAns(QNo - 1) = 3
AssignValues
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
    End
Else
    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)
    DoEvents
        ' 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
    Loop
    End With
    Debug.Print "came here"
    isRunning = False
    StopQuiz True
    End
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

Select allOpen in new window