Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 08-01-2021, 10:01 AM
tanktata tanktata is offline Using clickable textboxes and saving their captions Windows 10 Using clickable textboxes and saving their captions Office 2019
Novice
Using clickable textboxes and saving their captions
 
Join Date: Aug 2021
Location: Manchester UK
Posts: 4
tanktata is on a distinguished road
Default 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
Any help would be appreciated.
Reply With Quote
  #2  
Old 08-01-2021, 11:20 AM
JohnWilson JohnWilson is offline Using clickable textboxes and saving their captions Windows 10 Using clickable textboxes and saving their captions Office 2016
Programmer
 
Join Date: Nov 2008
Location: UK
Posts: 1,855
JohnWilson will become famous soon enoughJohnWilson will become famous soon enough
Default

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
__________________
Microsoft PowerPoint MVP
Free Advanced PowerPoint Tips and Tutorials
Reply With Quote
  #3  
Old 08-04-2021, 03:01 PM
tanktata tanktata is offline Using clickable textboxes and saving their captions Windows 10 Using clickable textboxes and saving their captions Office 2019
Novice
Using clickable textboxes and saving their captions
 
Join Date: Aug 2021
Location: Manchester UK
Posts: 4
tanktata is on a distinguished road
Default

Quote:
Originally Posted by JohnWilson View Post
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.
Reply With Quote
  #4  
Old 08-06-2021, 02:57 AM
tanktata tanktata is offline Using clickable textboxes and saving their captions Windows 10 Using clickable textboxes and saving their captions Office 2019
Novice
Using clickable textboxes and saving their captions
 
Join Date: Aug 2021
Location: Manchester UK
Posts: 4
tanktata is on a distinguished road
Default

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?
Reply With Quote
  #5  
Old 08-06-2021, 06:10 AM
JohnWilson JohnWilson is offline Using clickable textboxes and saving their captions Windows 10 Using clickable textboxes and saving their captions Office 2016
Programmer
 
Join Date: Nov 2008
Location: UK
Posts: 1,855
JohnWilson will become famous soon enoughJohnWilson will become famous soon enough
Default

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
__________________
Microsoft PowerPoint MVP
Free Advanced PowerPoint Tips and Tutorials
Reply With Quote
  #6  
Old 08-08-2021, 04:31 AM
tanktata tanktata is offline Using clickable textboxes and saving their captions Windows 10 Using clickable textboxes and saving their captions Office 2019
Novice
Using clickable textboxes and saving their captions
 
Join Date: Aug 2021
Location: Manchester UK
Posts: 4
tanktata is on a distinguished road
Default

Quote:
Originally Posted by JohnWilson View Post
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 🙂
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
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
Using clickable textboxes and saving their captions Captions: Changing captions in Appendix update all captions carnestw Word 3 10-27-2015 12:34 PM
Using clickable textboxes and saving their captions Saving graphics using captions ChrisBrewster Word VBA 1 11-15-2014 01:08 AM
Using clickable textboxes and saving their captions VBA to insert captions without appending to existing captions Marrick13 Word VBA 16 02-19-2012 06:06 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 05:58 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2021, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2021 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft