Using clickable textboxes and saving their captions

tanktata · #1 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.

JohnWilson · #2 08-01-2021, 11:20 AM

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

tanktata · #3 08-04-2021, 03:01 PM

Quote:

Originally Posted by JohnWilson

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

Thanks for this, I'll give it a try and let you know.

No experience of vb in PowerPoint so I need all the help I can get.

tanktata · #4 08-06-2021, 02:57 AM

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?

JohnWilson · #5 08-06-2021, 06:10 AM

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

tanktata · #6 08-08-2021, 04:31 AM

Quote:

Originally Posted by JohnWilson

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

That works a treat. Thanks a lot for the assistance 🙂

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