View Single Post
 
Old 08-04-2021, 03:01 PM
tanktata tanktata is offline Windows 10 Office 2019
Novice
 
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