Powerpoint and macros

[jj66]

I wonder if anyone here can help me. If got a presentation in powerpoint
that has some multi choice questions. The last slide tells the user how many
questions they got correct.
Okay, so I'm fine up to this point but what I want to do is include a button
or something on the last slide which the user would have to click on to
close the presentation (I'm ok with that) but emails the score or the last
slide back to me.
This is the original code I picked up somewhere.
Any information will be gratefully received

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.TextRa
nge.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(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).TextFram
e.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 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

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
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)
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

 

[Rick B]

This is a microsoft ACCESS newsgroup. You might try the Microsoft POWER
POINT newsgroup.

Rick B

 

[jj66]

I did but they don't know.

This is a microsoft ACCESS newsgroup. You might try the Microsoft POWER
POINT newsgroup.

Rick B



SlideShowWindows(1).Presentation.Slides("QSlide").Shapes(1).TextFrame.TextRa
..Presentation.Slides("EndSlide").Shapes("Closing").TextFrame.TextRange.Text
..Presentation.Slides("EndSlide").Shapes("Closing").TextFrame.TextRange.Text
SlideShowWindows(1).Presentation.Slides("QSlide").Shapes(ShapeName).TextFram