#1
|
|||
|
|||
Using clickable textboxes and saving their captions
I'm in the process of trying to get a powerpoint quiz to work.
It has a title slide with a clickable textbox used to start the 'quiz'. There are then 10 slides, each of which has 4 clickable textboxes, 1 is the correct answer and the other 3 are incorrect answers. It then has final slide with an end quiz textbox, which sends the score out of 10, and a overall percentage to an excel file. This all works fine but I've been asked to include the answers collected from each question and I cant figure out how to get that info. I think I'd need to store each answer in an array, but dont know where to include that in the current code. Its a work thing, so I cant attach a copy of the quiz itself, but here is the code I've been working with. Code:
'Dim AnswerSelected() Sub SaveToExcel() 'ADDED Dim oXLApp As Object Dim oWb As Object Dim row As Long Set oXLApp = CreateObject("Excel.Application") 'On a Mac change \ to : in the following line Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & ' Change excel file name to suit If oWb.Worksheets(1).Range("A1") = "" Then oWb.Worksheets(1).Range("A1") = "Name" oWb.Worksheets(1).Range("B1") = "" oWb.Worksheets(1).Range("C1") = "Date" oWb.Worksheets(1).Range("D1") = "Number Correct" oWb.Worksheets(1).Range("E1") = "Number Incorrect" oWb.Worksheets(1).Range("F1") = "Percentage" End If row = 2 While oWb.Worksheets(1).Range("A" & row) <> "" row = row + 1 Wend oWb.Worksheets(1).Range("A" & row) = userNameType oWb.Worksheets(1).Range("B" & row) = UserName() oWb.Worksheets(1).Range("C" & row) = Date oWb.Worksheets(1).Range("D" & row) = numCorrect oWb.Worksheets(1).Range("E" & row) = numIncorrect oWb.Worksheets(1).Range("F" & row) = 100 * (numCorrect / (numCorrect + numIncorrect)) oWb.Save oWb.Close End Sub Sub GetStarted() Initialize YourName ActivePresentation.SlideShowWindow.View.Next End Sub Sub Initialize() numCorrect = 0 numIncorrect = 0 qAnswered = False End Sub Sub YourName() userNameType = InputBox("Type your name") End Sub Sub RightAnswer() If qAnswered = False Then numCorrect = numCorrect + 1 End If qAnswered = False 'MsgBox "Your doing well, " & userNameType ActivePresentation.SlideShowWindow.View.Next End Sub Sub WrongAnswer() If qAnswered = False Then numIncorrect = numIncorrect + 1 End If qAnswered = False 'if giving answer change back to True 'MsgBox "Try to do better next time, " & userNameType ActivePresentation.SlideShowWindow.View.Next End Sub Sub Feedback() MsgBox "You got " & numCorrect & " out of " _ & numCorrect + numIncorrect & ", " & userNameType SaveToExcel 'ADDED End Sub Public Function UserName() UserName = Environ$("UserName") End Function Sub End_Test() With Application For Each w In .Presentations w.Save Next w .Quit End With End Sub |
#2
|
|||
|
|||
This will need a little more work but should give a start.
Code:
Dim numCorrect As Long Dim numincorrect As Long Dim userNameType As String Dim rayResult(1 To 10) As String Dim count As Long Sub SaveToExcel() 'ADDED Dim oXLApp As Object Dim oWb As Object Dim row As Long Dim L As Long Set oXLApp = CreateObject("Excel.Application") 'On a Mac change \ to : in the following line Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "result.xlsx") If oWb.Worksheets(1).Range("A1") = "" Then oWb.Worksheets(1).Range("A1") = "Name" oWb.Worksheets(1).Range("B1") = "" oWb.Worksheets(1).Range("C1") = "Date" oWb.Worksheets(1).Range("D1") = "Number Correct" oWb.Worksheets(1).Range("E1") = "Number Incorrect" oWb.Worksheets(1).Range("F1") = "Percentage" For L = 1 To 10 oWb.Worksheets(1).Range("F1").Offset(0, L) = "Q: " & L Next L End If row = 2 While oWb.Worksheets(1).Range("A" & row) <> "" row = row + 1 Wend oWb.Worksheets(1).Range("A" & row) = userNameType oWb.Worksheets(1).Range("B" & row) = UserName() oWb.Worksheets(1).Range("C" & row) = Date oWb.Worksheets(1).Range("D" & row) = numCorrect oWb.Worksheets(1).Range("E" & row) = numincorrect oWb.Worksheets(1).Range("F" & row) = 100 * (numCorrect / (numCorrect + numincorrect)) For L = 1 To 10 oWb.Worksheets(1).Range("F" & row).Offset(0, L) = rayResult(L) Next L oWb.Save oWb.Close End Sub Sub GetStarted() Initialize YourName ActivePresentation.SlideShowWindow.View.Next End Sub Sub Initialize() numCorrect = 0 numincorrect = 0 qAnswered = False count = 0 End Sub Sub YourName() userNameType = InputBox("Type your name") End Sub Sub RightAnswer() If qAnswered = False Then numCorrect = numCorrect + 1 count = count + 1 rayResult(count) = "CORRECT" End If qAnswered = False 'MsgBox "Your doing well, " & userNameType ActivePresentation.SlideShowWindow.View.Next End Sub Sub WrongAnswer() If qAnswered = False Then numincorrect = numincorrect + 1 count = count + 1 rayResult(count) = "INCORRECT" End If qAnswered = False 'if giving answer change back to True 'MsgBox "Try to do better next time, " & userNameType ActivePresentation.SlideShowWindow.View.Next End Sub Sub Feedback() MsgBox "You got " & numCorrect & " out of " _ & numCorrect + numincorrect & ", " & userNameType SaveToExcel 'ADDED End Sub Public Function UserName() UserName = Environ$("UserName") End Function Sub End_Test() With Application For Each w In .Presentations w.Save Next w .Quit End With End Sub |
#3
|
|||
|
|||
Quote:
No experience of vb in PowerPoint so I need all the help I can get. |
#4
|
|||
|
|||
That's more or less what I wanted but instead of showing the word CORRECT or INCORRECT in the results, would it be possible to show the caption of rhevtextbox that's been clicked?
|
#5
|
|||
|
|||
Assuming you are using standar shapes for questions you might be able to use
Code:
Sub RightAnswer(oshp As Shape) If qAnswered = False Then numCorrect = numCorrect + 1 count = count + 1 rayResult(count) = oshp.TextFrame2.TextRange End If qAnswered = False 'MsgBox "Your doing well, " & userNameType ActivePresentation.SlideShowWindow.View.Next End Sub Sub WrongAnswer(oshp As Shape) If qAnswered = False Then numincorrect = numincorrect + 1 count = count + 1 rayResult(count) = oshp.TextFrame2.TextRange End If qAnswered = False 'if giving answer change back to True 'MsgBox "Try to do better next time, " & userNameType ActivePresentation.SlideShowWindow.View.Next End Sub |
#6
|
|||
|
|||
Quote:
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
VBA to insert captions without appending to existing captions | Marrick13 | Word VBA | 17 | 03-21-2023 07:51 PM |
Table captions changing to Figure captions and vice versa | alicatsmom | Word Tables | 0 | 06-11-2019 08:51 AM |
Update Userform Captions, TextBoxes, Command buttons From Excel | dan88 | Word VBA | 3 | 05-22-2016 08:59 AM |
Captions: Changing captions in Appendix update all captions | carnestw | Word | 3 | 10-27-2015 12:34 PM |
Saving graphics using captions | ChrisBrewster | Word VBA | 1 | 11-15-2014 01:08 AM |