Using clickable textboxes and saving their captions

[tanktata]

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.

'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

Any help would be appreciated.