Unable to get complete word doc for second time using VBA from PPT

[Adrian Smith]

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

 

[alborg]

Hi Adrian:

Your project sounds a bit complicated, but I'll take a stab at it. Your
problem seems to be that you are losing your test taker's personal settings
when you refresh your document.

What I think your problem resides is in the fact that you need to do is to
store the contents of your variables into the system registry by using the
the "PrivateProfileString" method.

An excellent PDF on this topic is found here-
http://www.tech-archive.net/pdf/Archive/Word/microsoft.public.word.vba.beginners/2004-06/0022.pdf

It'll store it locally.

Now, if you wish to store this information on, say, a centralized server on
a LAN, then you need to make a simple Access database table holding the
personal files of all the test takers which can be accessed easily by any
Word document via VBA code. All test taker Word printouts can then link to
for the needed information. This Access table can also be placed on each
local computer too. It's not that difficult a process.

So what would work best for you? Am I barking up the right tree here? We can
go into this further, if you wish.

Cheers,
Al

 

[Adrian Smith]

Al

Many thanks for your reply and I think I understand the concept after
reading the articles.

However, as most of our work relates to operations on site away from any
permanent office location the courses are to be mounted on laptops which have
security protection. Hence I am trying to keep the number of programs used to
a minimum (where possible).

I think it may be useful if I explained the sequence of events which are :
1. Show PPT training course and then first users take quiz
2. First user takes quiz
3. User enters name (initialise and reset all variables)
4. Take quiz (each answer “correct or incorrect†saved to variable and each
answer sent to a slide which will summarise user answers)
5. After selecting answer to last question, PPT summary slide finalised by
adding number of correct answers and percentage correct.
6. Word doc created from template and saved with file name created from
users name and date quiz taken.
7. Word doc populated with user answers, number of correct answers and
percentage correct, then file is saved and Word closed.
8. User views summary slide showing answers etc.
9. Training course completed or next user takes quiz by returning back to
step 3 etc.

I have looked at the code relating to steps 5 to 7 and have simplified it to
the following :

Sub summary()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim usermonth, useryear, userday

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

'dateforsave
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

'dataforheader
ActiveDocument.Bookmarks("User_name").Range.Text = userName
ActiveDocument.Bookmarks("Date_of_quiz").Range.Text = userdate

‘populate answer table within word
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

End Sub

As mentioned before the first post the above code runs OK, a new fully
populated document is created and saved. The second time the code is called a
new user file is created and saved but the newly created document is not
populated. The code seems to stop working at the point where “dataforheaderâ€
is called.

I would like to try and sort this problem out if at all possible before
changing to another method e.g that provided in your reply.

Thanks for your help and a happy new year.

Adrian

 

[Adrian Smith]

Al

I found the answer eventually after reading the thread below :

http://www.xtremevbtalk.com/showthread.php?t=135815

This tread relates to Excel and Access but was relevant to my problem. In
essence it may seem like a cruel joke, but any usage of the global
'Application' reference will appear to run correctly within VB 6.0, but in
fact this is true only the first time that you run the code. Unfortunately,
theVB6 App would be unable to release the 'Application' global reference and
in my case the Word instance would "hang", unable to close.

Hence I have replaced all reference to “ActiveDocument†and replaced with
“wdDocâ€. Code now works OK.

Adrian

 

[alborg]

The best Word information can be found in most Excel threads.

BTW, you don't need MS Access, just a simple Access table to refer to!

I'm glad that it works. If it later doesn't, I can upload a simple Word
program that I use to lock folks out using the registry. It counts the number
of times that the template has been opened, then if it exceeds 50, it locks
the user out.

Cheers,
Al