Firstly I apologise if this question / problem is in the incorrect forum.
I have been using PPT to produce several internal training modules over the
months each of which contains a quiz. Following an internal review the
modules are to be automated so that each individual’s quiz results are saved
in a word doc. Being a newbie to VB I have managed to get all the code
working to produce a word doc from a template that is saved for any
individual user. The code is initialised when the quiz commences.
However, I have the problem that the code only works correctly once, when
the quiz is first initiated. If you use the inbuilt hyperlinks within the PPT
Pres it is possible to retake the quiz without first exiting PPT and then
restarting it (good if there are more than one user taming the training
module). When I look at the second word doc the file is saved correctly but
the doc has not been populated with the users name, answers etc. Hence the
code stops working when procedure “dataforheader()†is called. Code is
pesented below:
Dim userName As String
Dim qAnswered(8) As Boolean
Dim numCorrect As Integer
Dim numIncorrect As Integer
Dim answer(8) As String
Dim rightwrong(8) As String
Dim wdApp As Word.Application, wdDoc As Word.Document
Dim userdate, usersave
Sub GetStarted()
Initialise
YourName
MsgBox ("Thank you, " & userName & ", we will now begin the Quiz.")
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(1,
3).Shape.TextFrame.TextRange.Text = userName
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Initialise()
Dim i As Long
Dim n As Long
numCorrect = 0
numIncorrect = 0
userName = ""
userdate = 0
usersave = 0
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(1,
3).Shape.TextFrame.TextRange.Text = ""
For i = 1 To 8
qAnswered(i) = False
answer(i) = ""
n = i + 3
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(n,
3).Shape.TextFrame.TextRange.Text = ""
Next i
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(11,
1).Shape.TextFrame.TextRange.Text = ""
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(12,
1).Shape.TextFrame.TextRange.Text = ""
End Sub
Sub YourName()
Dim done As Boolean
done = False
While Not done
userName = InputBox(prompt:="Enter your name", Title:="Input Name")
If userName = "" Then
done = False
Else
done = True
End If
Wend
End Sub
Sub RightAnswerButton(answerButton As Shape)
Dim thisQuestionNum As Long
thisQuestionNum = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex -
76
answer(thisQuestionNum) = answerButton.TextFrame.TextRange.Text
If qAnswered(thisQuestionNum) = False Then
numCorrect = numCorrect + 1
rightwrong(thisQuestionNum) = "c"
End If
qAnswered(thisQuestionNum) = True
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(thisQuestionNum + 2, 3).Shape.TextFrame.TextRange.Text = answer(thisQuestionNum)
If thisQuestionNum = 8 Then
summary
End If
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub WrongAnswerButton(answerButton As Shape)
Dim thisQuestionNum As Long
thisQuestionNum = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex -
76
answer(thisQuestionNum) = answerButton.TextFrame.TextRange.Text
If qAnswered(thisQuestionNum) = False Then
numIncorrect = numIncorrect + 1
rightwrong(thisQuestionNum) = "w"
End If
qAnswered(thisQuestionNum) = True
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(thisQuestionNum + 2, 3).Shape.TextFrame.TextRange.Text = answer(thisQuestionNum)
If thisQuestionNum = 8 Then
summary
End If
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub summary()
Dim rightanswers As String
Dim percentright As String
rightanswers = "Answers Correct : " & numCorrect & " out of " & numCorrect +
numIncorrect & " answers correct."
percentright = "Percentage Correct : " & Round(100 * numCorrect /
(numIncorrect + numCorrect), 1) & "% "
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(11,
1).Shape.TextFrame.TextRange.Text = rightanswers
ActivePresentation.Slides(86).Shapes("Answertable").Table.Cell(12,
1).Shape.TextFrame.TextRange.Text = percentright
openwordoc
dateforsave
dataforheader
For i = 1 To 8
ActiveDocument.Tables(1).Rows(i + 1).Cells(3).Range.Text = answer(i)
If rightwrong(i) = "c" Then
ActiveDocument.Tables(1).Rows(i + 1).Cells(4).Range.Text = "correct"
Else
ActiveDocument.Tables(1).Rows(i + 1).Cells(4).Range.Text = "Incorrect"
ActiveDocument.Tables(1).Rows(i + 1).Cells(4).Range.Font.Bold = wdToggle
ActiveDocument.Tables(1).Rows(i + 1).Cells(3).Range.Font.Bold = wdToggle
End If
Next i
ActiveDocument.Bookmarks("WR").Range.Text = rightanswers
ActiveDocument.Bookmarks("PR").Range.Text = percentright
wdDoc.Save
wdDoc.Close ' close the document
wdApp.Quit ' close the Word application
Set wdDoc = Nothing
Set wdApp = Nothing
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub openwordoc()
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open("d:\working\training\Rig Safety\Rig Safety
Quiz v1.dot")
End Sub
Sub dateforsave()
Dim usermonth, useryear, userday, try
userdate = Now
useryear = Year(userdate) - 2000
usermonth = Month(userdate) * 100
userday = Day(userdate) * 10000
usersave = userday + usermonth + useryear
If usersave > 100000 Then
filenm = "d:\working\training\Rig Safety\RSQ " & userName & " " & usersave &
".doc"
Else
filenm = "d:\working\training\Rig Safety\RSQ " & userName & " " & "0" &
usersave & ".doc"
End If
wdDoc.SaveAs filenm
End Sub
Sub dataforheader()
ActiveDocument.Bookmarks("User_name").Range.Text = userName
ActiveDocument.Bookmarks("Date_of_quiz").Range.Text = userdate
End Sub
I am sure the above code is not correct somewhere, any help would be much
appreciated
Adrian
|
|