I am using form name "Registration for the test" to gather data, it is asking for Name, ID and Category from User. and Loading up Form TEST with right category and 25 questions.
Once completed it is loading up report name REPORT with Name, ID, Percentage of Marks, Category and Wrong questions. Also saving feedback in Users Table.
Below is the Code I'm Using
Option Compare Database
Sub SleepVB(Seconds)
Dim Start
Start = Timer
Do While Timer < Start + Seconds
DoEvents
Loop
End Sub
Private Sub Command6_Click()
Dim dbs As Database
Dim rst As Recordset
Dim mystrSQL As String
Dim name As String
Dim staff_ID As String
Dim Category As String
Application.SetOption "Confirm Record Changes", False
Application.SetOption "Confirm Document Deletions", False
Application.SetOption "Confirm Action Queries", False
' ----------------------------------------------------------------------
If IsNull(Me.Text0.Value) Then
MsgBox ("Error! Enter the name, please")
Else
name = Me.Text0.Value
If IsNull(Me.Text4.Value) Then
MsgBox ("Error! Enter the staff ID, please")
Else
staff_ID = Me.Text4.Value
If IsNull(Me.Combo9.Value) Then
MsgBox ("Error! Enter the category, please")
Else
Category = Me.Combo9.Column(1)
' DoCmd.Close acForm, "Registration for the test"
Dim i&, a&, z&, x&, y&, j&, answers&, mark&, s$
Dim responding As Boolean
Dim responding2 As Boolean
' z - he number of questions selected category. Must be 50, but check it:
' x - the number of questions asked, must be 25
' y - the current number of unasked question
' answers - number of correct answers
' mark - received points
x = 25
' x = 3
z = 185
answers = 0
Dim arrayAnswers(25 - 1) As Integer
Dim arrayAnswersIncorrect(25 - 1) As Integer
mystrSQL = "SELECT Nz(Count(Questions.ID_question),0) AS CountOfID_question "
mystrSQL = mystrSQL & "FROM Categories LEFT JOIN Questions ON Categories.ID_category = Questions.Category "
mystrSQL = mystrSQL & "GROUP BY Categories.ID_category "
mystrSQL = mystrSQL & "HAVING (((Categories.ID_category)=" & Category & "))"
mystrSQL = "SELECT Nz(Count(Questions.ID_question),0) AS CountOfID_question "
mystrSQL = mystrSQL & "FROM Categories LEFT JOIN Questions ON Categories.ID_category = Questions.Category "
mystrSQL = mystrSQL & "GROUP BY Categories.my_category HAVING (((Categories.my_category)=""" & Category & """));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(mystrSQL)
z = rst![CountOfID_question].Value
Randomize
For i = 1 To x
arrayAnswers(i - 1) = 0
arrayAnswersIncorrect(i - 1) = 0
Next
For i = 1 To x
Do
responding = True
y = CInt(Int((z * Rnd()) + 1))
mystrSQL = "SELECT Questions.ID_question FROM Categories INNER JOIN Questions ON Categories.ID_category = Questions.Category "
mystrSQL = mystrSQL & "WHERE (((Questions.[Number question])=" & y & ") AND ((Categories.my_category)=""" & Category & """))"
Set rst = dbs.OpenRecordset(mystrSQL)
If (rst.RecordCount > 0) Then
responding2 = True
' get the data on viewing this question # y
For a = 1 To x
If arrayAnswers(a - 1) = y Then
responding2 = False
End If
Next
If (Not responding2) Then
responding = False
End If
Else
responding = False
End If
rst.Close
' Exit Do
Loop While (Not responding)
arrayAnswers(i - 1) = y
' selection question
mystrSQL = "SELECT Questions.[Number question], Questions.Question, Categories.my_category, Answers.Answer, Answers.[Correct answer] "
mystrSQL = mystrSQL & "FROM (Categories INNER JOIN Questions ON Categories.ID_category = Questions.Category) INNER JOIN Answers ON Questions.ID_question = Answers.Question "
mystrSQL = mystrSQL & "GROUP BY Questions.[Number question], Questions.Question, Categories.my_category, Answers.Answer, Answers.[Correct answer], Questions.ID_question "
' mystrSQL = mystrSQL & "HAVING (((Questions.ID_question)=" & y & "))"
mystrSQL = mystrSQL & "HAVING (((Questions.[Number question])=" & y & "))"
CurrentDb.QueryDefs("Query1").SQL = mystrSQL
CurrentDb.QueryDefs("Query1").OpenRecordset
DoCmd.OpenForm "Testing", acNormal
'
Do While Forms![Testing].Controls![Text16].Value = 0
SleepVB (1)
Loop
If Forms![Testing].Controls![Text16].Value = 1 Then
answers = answers + 1
Else
If Forms![Testing].Controls![Text16].Value = -1 Then
arrayAnswersIncorrect(i - 1) = y
End If
End If
DoCmd.Close acForm, "Testing"
Next
Dim myTime As Date
' --------------------------------------------------------------------------------------------------------------
i = (100 * answers) / x
myTime = CDate(Now())
mystrSQL = "INSERT INTO Users ( Name, [Date], [Staff ID], Points, my_category ) "
mystrSQL = mystrSQL & "values(""" & name & """, #" & myTime & "#, """ & staff_ID & """, " & i & ", """ & Category & """)"
DoCmd.RunSQL mystrSQL
' --------------------------
Dim str As String
str = ""
For a = 1 To x
If arrayAnswersIncorrect(a - 1) > 0 Then
str = str & " (((Questions.[Number question])=" & a & ")) OR"
End If
Next
If str = "" Then
mystrSQL = "SELECT Users.Name, Users.Date, Users.[Staff ID], Users.Points, Users.my_category, " & """"" AS Question FROM Users "
mystrSQL = mystrSQL & "WHERE (((Users.Name)=""" & name & """) AND ((Users.Date)=#" & myTime & "#) AND ((Users.[Staff ID])=""" & staff_ID & """) AND ((Users.my_category)=""" & Category & """) AND ((Users.Points)=" & i & "))"
Else
mystrSQL = "SELECT Users.Name, Users.Date, Users.[Staff ID], Users.Points, Users.my_category, Questions.Question "
mystrSQL = mystrSQL & "FROM Users, Questions WHERE "
' delete last word - OR
j = InStrRev(str, " ")
If j > 0 Then
mystrSQL = mystrSQL & Left$(str, j)
End If
mystrSQL = mystrSQL & " GROUP BY Questions.Question, Users.Name, Users.Date, Users.[Staff ID], Users.my_category, Users.Points "
mystrSQL = mystrSQL & "HAVING (((Users.Name)=""" & name & """) AND ((Users.Date)=#" & myTime & "#) AND ((Users.[Staff ID])=""" & staff_ID & """) AND ((Users.my_category)=""" & Category & """) AND ((Users.Points)=" & i & "))"
End If
If i < 80 Then
MsgBox ("Sorry, you have not passed testing...")
End If
Debug.Print mystrSQL
CurrentDb.QueryDefs("Query2").SQL = mystrSQL
' --------------------------
DoCmd.OpenReport "Report", acViewPreview, , stLinkCriteria
End If
End If
End If
' ----------------------------------------------------------------------
Application.SetOption "Confirm Record Changes", True
Application.SetOption "Confirm Document Deletions", True
Application.SetOption "Confirm Action Queries", True
End Sub
