Microsoft Office Forums - View Single Post - Using clickable textboxes and saving their captions

tanktata · 08-01-2021, 10:01 AM

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

Any help would be appreciated.