Quiz

<% '----------------------------------------------------------------------------------------' 'iLanguage values: ' Const LanguageArabic = 1025 Const LanguageCzech = 1029 Const LanguageDanish = 1030 Const LanguageEnglish = 1033 Const LanguageFinnish = 1035 Const LanguageFrench = 1036 Const LanguageGerman = 1031 Const LanguageHebrew = 1037 Const LanguageHungarian = 1038 Const LanguageItalian = 1040 Const LanguageNorwegian = 1044 Const LanguagePolish = 1045 Const LanguageSpanish = 3082 Const LanguageSwedish = 1053 Const LanguageThai = 1054 '----------------------------------------------------------------------------------------' '----------------------------------------------------------------------------------------' 'Do not translate application variable "$ErrorMessage" ' '----------------------------------------------------------------------------------------' Dim iLanguage, sLanguageString(45) iLanguage = LanguageEnglish If iLanguage = LanguageEnglish Then sLanguageString(0) = "Created and managed with SmartLite WebQuiz XP" sLanguageString(1) = "Password:" sLanguageString(2) = " Unable to continue: you cannot submit your answers more than one time." sLanguageString(3) = "User Name:" sLanguageString(4) = "Password:" sLanguageString(5) = "Unable to continue: you cannot access the test again." sLanguageString(6) = "Unable to load questions. Database cannot be found or connection to database cannot be opened. Error message: $ErrorMessage" sLanguageString(7) = "Unable to get the quiz ID. Error message: $ErrorMessage" sLanguageString(8) = "Unable to get the quiz ID. The record cannot be found." sLanguageString(9) = "Unable to load questions. The database may be read-only. Please check that you have write permissions in the database folder. Error message: $ErrorMessage" sLanguageString(10) = "Unable to load questions. The database may be locked. Please wait a few moments and then retry. Error message: $ErrorMessage" sLanguageString(11) = "Unable to save answers. The database may be locked. Please wait a few moments and then retry. Error message: $ErrorMessage" sLanguageString(12) = "Unable to continue: your answers have already been submitted." sLanguageString(13) = "Unable to save answers. The database may be locked or the administrator may have deleted you. Please wait a few moments and then retry. Error message: $ErrorMessage" sLanguageString(14) = "Unable to save answers. The database may be locked or the administrator may have deleted you. Error message: $ErrorMessage" sLanguageString(15) = "Unable to save answers. The database may be locked or the administrator may have deleted you. Error message: $ErrorMessage" sLanguageString(16) = "Unable to load questions. The database may be locked. Please wait a few moments and then retry. Error message: $ErrorMessage" sLanguageString(17) = "Score:" sLanguageString(18) = "Date:" sLanguageString(19) = "IP:" sLanguageString(20) = "Score:" sLanguageString(21) = "Score: " sLanguageString(22) = "Evaluation:" sLanguageString(23) = "Evaluation: " sLanguageString(24) = "Unable to save answers. The database may be locked or the administrator may have deleted you. Error message: $ErrorMessage" sLanguageString(25) = "Unable to load questions. The database may be locked. Please wait a few moments and then retry. Error message: $ErrorMessage" sLanguageString(26) = "Unable to load questions. No questions have been found." sLanguageString(27) = "Question " sLanguageString(28) = "Given Answer" sLanguageString(29) = "Correct Answer" sLanguageString(30) = "Answers from quiz: " sLanguageString(31) = "Print" sLanguageString(32) = "Begin" sLanguageString(33) = "Reset" sLanguageString(34) = "< Back" sLanguageString(35) = "Submit" sLanguageString(36) = "Next >" sLanguageString(37) = "Submit" sLanguageString(38) = "Reset" sLanguageString(39) = "Please enter a value for " sLanguageString(40) = "Please enter a valid e-mail." sLanguageString(41) = "Please choose a value for question " sLanguageString(42) = "Please choose at least one value for question " sLanguageString(43) = "Please enter a value for question " sLanguageString(44) = "Right" sLanguageString(45) = "Wrong" ElseIf iLanguage = LanguageItalian Then sLanguageString(0) = "Creato e gestito con SmartLite WebQuiz XP" sLanguageString(1) = "Password:" sLanguageString(2) = "Impossibile continuare: le risposte possono essere inviate una sola volta." sLanguageString(3) = "Utente:" sLanguageString(4) = "Password:" sLanguageString(5) = "Impossibile continuare: il test non può più essere svolto." sLanguageString(6) = "Impossibile caricare le domande. Il database non è stato trovato oppure la connessione al database non è riuscita. Messaggio di errore: $ErrorMessage" sLanguageString(7) = "Impossibile ottenere l'ID del quiz. Messaggio di errore: $ErrorMessage" sLanguageString(8) = "Impossibile ottenere l'ID del quiz. Il record non è stato trovato." sLanguageString(9) = "Impossibile caricare le domande. Il database potrebbe essere di sola lettura. Assicurarsi di avere i permessi di scrittura nella cartella del database. Messaggio di errore: $ErrorMessage" sLanguageString(10) = "Impossibile caricare le domande. Il database potrebbe essere bloccato. Attendere alcuni minuti e riprovare. Messaggio di errore: $ErrorMessage" sLanguageString(11) = "Impossibile salvare le risposte. Il database potrebbe essere bloccato. Attendere alcuni minuti e riprovare. Messaggio di errore: $ErrorMessage" sLanguageString(12) = "Impossibile continuare: le risposte sono già state inviate." sLanguageString(13) = "Impossibile salvare le risposte. Il database potrebbe essere bloccato oppure l'amministratore potrebbe avere cancellato la tua utenza. Attendere alcuni minuti e riprovare. Messaggio di errore: $ErrorMessage" sLanguageString(14) = "Impossibile salvare le risposte. Il database potrebbe essere bloccato oppure l'amministratore potrebbe avere cancellato la tua utenza. Messaggio di errore: $ErrorMessage" sLanguageString(15) = "Impossibile salvare le risposte. Il database potrebbe essere bloccato oppure l'amministratore potrebbe avere cancellato la tua utenza. Messaggio di errore: $ErrorMessage" sLanguageString(16) = "Impossibile caricare le domande. Il database potrebbe essere bloccato. Attendere alcuni minuti e riprovare. Messaggio di errore: $ErrorMessage" sLanguageString(17) = "Score:" sLanguageString(18) = "Date:" sLanguageString(19) = "IP:" sLanguageString(20) = "Score:" sLanguageString(21) = "Score: " sLanguageString(22) = "Valutazione:" sLanguageString(23) = "Valutazione: " sLanguageString(24) = "Impossibile salvare le risposte. Il database potrebbe essere bloccato oppure l'amministratore potrebbe avere cancellato la tua utenza. Messaggio di errore: $ErrorMessage" sLanguageString(25) = "Impossibile caricare le domande. Il database potrebbe essere bloccato. Attendere qualche minuto e riprovare. Messaggio di errore: $ErrorMessage" sLanguageString(26) = "Impossibile caricare le domande. Non è stata trovata nessuna domanda." sLanguageString(27) = "Domanda " sLanguageString(28) = "Risposta data" sLanguageString(29) = "Risposta esatta" sLanguageString(30) = "Risposte dal quiz: " sLanguageString(31) = "Stampa" sLanguageString(32) = "Inizia" sLanguageString(33) = "Reset" sLanguageString(34) = "< Indietro" sLanguageString(35) = "Invia" sLanguageString(36) = "Avanti >" sLanguageString(37) = "Invia" sLanguageString(38) = "Reset" sLanguageString(39) = "Inserire un valore per il campo " sLanguageString(40) = "Inserire un indirizzo di posta elettronica valido." sLanguageString(41) = "Selezionare un valore per la domanda " sLanguageString(42) = "Selezionare almeno un valore per la domanda " sLanguageString(43) = "Inserire un valore per la domanda " sLanguageString(44) = "Esatta" sLanguageString(45) = "Errata" End If %> <% DB_CONNECTION_STRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("../access_db/smwq_quiz_general5.mdb") & ";" QUIZ_TAG = "FZJEA" SAVE_ANSWERS = False QUESTIONS_TO_SHOW = -1 RANDOM_QUESTIONS = True RANDOM_ANSWERS = True PASSWORD = "" ALLOW_ONE_ACCESS = False MAX_TIME = -180 NO_BACK_BUTTON = True NO_USER_CHANGES = False SEND_ANSWERS_EMAIL_FROM = "najafov@gmail.com" SEND_ANSWERS_EMAIL = "najafov@gmail.com" SHOW_RIGHT_ANSWERS = True SHOW_FULL_RESULTS = True SHOW_TOTAL_SCORE = True SHOW_EVALUATION = True SHOW_COMMENT_AFTER_ANSWER = False MULTI_PAGE = True TIME_ZONE = 0 'SECURITY_OPTIONS = " ondragstart=""return false"" onselectstart=""return false"" onBeforePrint=""document.body.style.display = 'none';"" onAfterPrint=""document.body.style.display = 'block';""" SHOW_PRINT_BUTTON = True SEND_ANSWERS_EMAIL_FORMAT = 0 '0=Questions and all given answers 1=Questions and wrong given answers 2=Questions and all given answers and all correct answers CreditString = "

" & sLanguageString(0) & " " '--- Do not edit below this line --- iDBType = 0 If Instr(DB_CONNECTION_STRING, "Provider=SQLOLEDB.1") > 0 Then iDBType = 1 iTimeOut = Abs(MAX_TIME \ 60) * 2 If iTimeOut < 90 Then iTimeOut = 90 Session.TimeOut = iTimeOut lUserID = CLng(Request.Form("UserID")) iStatusID = CLng(Request.Form("StatusID")) '-1=Ready to evaluate, 0=First time, >0=Question number iDirection = CLng(Request.Form("Direction")) '1=Next, -1=Back sAnswersSequence = Request.Form("AnswersSequence") If iStatusID > 1 And iDirection = 1 And MULTI_PAGE And SHOW_COMMENT_AFTER_ANSWER And Request.Form("Comments") <> "" Then iStatusID = iStatusID - 1 bShowCommentsNow = True End If Function IsPrivateQuiz() OpenConnection True sSQL = "SELECT COUNT(*) FROM AllowedUsers" If iDBType = 1 Then sSQL = sSQL & " AND QuizID=" & iQuizID rsQuiz.Open sSQL, cnnQuiz, 1 IsPrivateQuiz = rsQuiz(0) > 0 CloseConnection rsQuiz, cnnQuiz End Function Function GetQuestionCount() OpenConnection True sSQL = "SELECT COUNT(*) FROM Questions" If iDBType = 1 Then sSQL = sSQL & " AND QuizID=" & iQuizID rsQuiz.Open sSQL, cnnQuiz, 1 GetQuestionCount = rsQuiz(0) CloseConnection rsQuiz, cnnQuiz End Function Function CheckPassword() If PASSWORD <> "" And UCase(Request.Form("TestPassword")) = UCase(PASSWORD) Then Session("TestPassword") = UCase(PASSWORD) If PASSWORD <> "" And Session("TestPassword") <> UCase(PASSWORD) Then PrintHeader "" Response.Write "" & vbCrLf Response.Write " " & vbCrLf Response.End End if If ALLOW_ONE_ACCESS And iStatusID <> 0 And bTestAlreadyDone And Not PRIVATE_QUIZ Then 'User pressed Evaluate button PrintHeader "" Response.Write "

" & sLanguageString(2) & "

" & vbCrLf Response.End End If End Function Function CheckLogin() Dim sSQL, i, bAlreadyDone, bCannotAccess If Request.Form("TestUserName") <> "" Or iStatusID = -1 Then 'Check if it is a valid UserID OpenConnection True If iStatusID = -1 Then sSQL = "SELECT * FROM AllowedUsers WHERE Username='" & Session("TestLoggedInUser" & QUIZ_TAG) & "' AND Pass='" & Session("TestLoggedInPassword" & QUIZ_TAG) & "'" Else sSQL = "SELECT * FROM AllowedUsers WHERE Username='" & Request.Form("TestUserName") & "' AND Pass='" & Request.Form("TestPassword") & "'" End If If iDBType = 1 Then sSQL = sSQL & " AND QuizID=" & iQuizID rsQuiz.Open sSQL, cnnQuiz , 1, 2 If Not rsQuiz.EOF Then bAlreadyDone = rsQuiz("LastRun") <> "" If iStatusID = -1 Then rsQuiz("LastRun") = DateAdd("n", TIME_ZONE, Now) rsQuiz.Update Else If rsQuiz("Accesses") < 1 And rsQuiz("Accesses") <> -1 Then bCannotAccess = True ElseIf rsQuiz("Accesses") > 0 Then rsQuiz("Accesses") = rsQuiz("Accesses") - 1 rsQuiz.Update End If Session("TestLoggedInUser" & QUIZ_TAG) = Request.Form("TestUserName") Session("TestLoggedInPassword" & QUIZ_TAG) = Request.Form("TestPassword") For i = 0 To rsQuiz.Fields.Count - 1 Session(rsQuiz.Fields(i).Name) = rsQuiz.Fields(i).Value Next If iDBType = 1 Then sSQL = "SELECT * FROM UserDataValues LEFT JOIN UserData ON UserDataValues.UserDataID = UserData.ID WHERE UserID=-" & rsQuiz("ID") rsQuiz.Close rsQuiz.Open sSQL, cnnQuiz , 1 Do While NOT rsQuiz.EOF Session("UD_" & rsQuiz("Name")) = rsQuiz("ValueText") rsQuiz.MoveNext Loop End If End If End If CloseConnection rsQuiz, cnnQuiz End If If Session("TestLoggedInUser" & QUIZ_TAG) = "" Then PrintHeader "" Response.Write "" & vbCrLf Response.Write " " & vbCrLf Response.End End If If (ALLOW_ONE_ACCESS And bAlreadyDone) Or bCannotAccess Then 'User accessed the quiz more than allowed PrintHeader "" Response.Write "

" & sLanguageString(5) & "

" & vbCrLf Session("TestLoggedInUser" & QUIZ_TAG) = "" Response.End End If If iStatusID = -1 Then Session("TestLoggedInUser" & QUIZ_TAG) = "" End Function Function GetAnswerNumbers(iMaxNumbers, iMaxNumbersToReturn, bRandom) Dim i, iNumber1, iNumber2, RandomNumbers, RandomNumbersTmp ReDim RandomNumbers(iMaxNumbers - 1) ReDim RandomNumbersTmp(iMaxNumbersToReturn) For i = 0 To UBound(RandomNumbers) RandomNumbers(i) = i + 1 Next Randomize i = iMaxNumbers - 1 If bRandom Then Do While i >= 0 And iMaxNumbersToReturn > 0 iNumber1 = Int((i + 1) * Rnd) + 0 iNumber2 = RandomNumbers(iNumber1) RandomNumbersTmp(iMaxNumbers - 1 - i) = iNumber2 RandomNumbers(iNumber1) = RandomNumbers(i) i = i - 1 iMaxNumbersToReturn = iMaxNumbersToReturn - 1 Loop Else RandomNumbersTmp = RandomNumbers End If GetAnswerNumbers = RandomNumbersTmp End Function Function GetGivenAnswer(iQuestionType, iQuestionID, iMaxAnswers) Dim i, sTmp Select Case iQuestionType Case 0, 2 'Multiple choice, True/False For i = 1 To iMaxAnswers If CInt(i) = CInt(Request.Form("q" & iQuestionID)) Then sTmp = sTmp & "1" Else sTmp = sTmp & "0" End If Next If Instr(sTmp, "1") < 1 Then sTmp = "" Case 1 'Multiple answer For i = 1 To iMaxAnswers sTmp = sTmp & CInt(Request.Form("q" & iQuestionID & "_a" & i)) Next If Instr(sTmp, "1") < 1 Then sTmp = "" Case 3 'Fill-In-The-Blank sTmp = Request.Form("q" & iQuestionID) End Select GetGivenAnswer = sTmp End Function Function FindPath(sFullPath) 'Returns the path Dim sTmp, sList If Len(sFullPath) = 0 Then Exit Function sList = Split(sFullPath, "/") sTmp = sList(UBound(sList)) FindPath = Left(sFullPath, Len(sFullPath) - Len(sTmp)) End Function Function GetTextFromField(vValue) If IsNull(vValue) Then GetTextFromField = "" Else GetTextFromField = vValue End If End Function Function GetFullGivenAnswer(sGivenAnswer, MyRs) Dim sNewAnswer, i If IsNull(sGivenAnswer) Or sGivenAnswer = "" Then Exit Function If MyRs("Type") = 3 Then 'Fill-in-the-blank sNewAnswer = sGivenAnswer Else For i = 1 To Len(sGivenAnswer) If Mid(sGivenAnswer, i, 1) = "1" Then sNewAnswer = sNewAnswer & MyRs("Answer" & i) & Chr(44) & Chr(32) Next If Len(sNewAnswer) > 0 Then sNewAnswer = Left(sNewAnswer, Len(sNewAnswer) - 2) 'Delete last Chr(44) & Chr(32) End If GetFullGivenAnswer = sNewAnswer End Function Function GetResult(sGivenAnswer, sRightAnswer, iQuestionType) Dim sTmp, i GetResult = 0 If IsNull(sRightAnswer) Or sRightAnswer = "" Then Exit Function Select Case iQuestionType Case 0, 1, 2, 3 'Multiple choice, Multiple answer, True/False, Fill-In-The-Blank sTmp = sGivenAnswer End Select GetResult = 3 'Null If UCase(sTmp) = UCase(sRightAnswer) Then GetResult = 1 'Right Else If Len(sTmp) > 0 Then GetResult = 2 'Wrong End If End Function Function GetResultPicture(iCount, sGivenAnswer, sRightAnswer, iQuestionType) GetResultPicture = "blank.gif" If sGivenAnswer = "" Or sRightAnswer = "" Or IsNull(sRightAnswer) Then Exit Function Select Case iQuestionType Case 0, 1, 2 'Multiple choice, Multiple answer, True/False If Mid(sGivenAnswer, iCount, 1) = "1" Then If Mid(sRightAnswer, iCount, 1) = "1" Then GetResultPicture = "success.gif" Else GetResultPicture = "fail.gif" End If End If Case 3 'Fill-In-The-Blank If UCase(sGivenAnswer) = UCase(sRightAnswer) Then GetResultPicture = "success.gif" Else GetResultPicture = "fail.gif" End If End Select End Function Function GetResultPicture2(iCount, sGivenAnswer, sRightAnswer, iQuestionType) Dim sTmp Select Case iQuestionType Case 0, 1, 2 'Multiple choice, Multiple answer, True/False If iQuestionType = 0 Or iQuestionType = 2 Then sTmp = "0" Else sTmp = "1" End If GetResultPicture2 = "check" & sTmp & "0.gif" 'Default If Mid(sRightAnswer, iCount, 1) = "1" And SHOW_RIGHT_ANSWERS Then GetResultPicture2 = "check" & sTmp & "2.gif" If Mid(sGivenAnswer, iCount, 1) = "1" Then GetResultPicture2 = "check" & sTmp & "1.gif" Case 3 'Fill-In-The-Blank GetResultPicture2 = "" End Select End Function Function GetPictureTooltip(sPicture) Select Case LCase(sPicture) Case "success.gif" GetPictureTooltip = sLanguageString(44) Case "fail.gif" GetPictureTooltip = sLanguageString(45) End Select End Function Function GetScore(iResult, iType, sGivenAnswer, iMaxAnswers) Dim sScore, i 'Score for question sScore = 0 Select Case iResult Case 0 'Nothing 'Do nothing Case 1 'Right If Not IsNull(rsQuiz("ScoreRight")) Then sScore = rsQuiz("ScoreRight") Case 2 'Wrong If Not IsNull(rsQuiz("ScoreWrong")) Then sScore = rsQuiz("ScoreWrong") Case 3 'Null If Not IsNull(rsQuiz("ScoreNull")) Then sScore = rsQuiz("ScoreNull") End Select 'Score for answer(s) Select Case iType Case 0, 1, 2 'Multiple choice, Multiple answer, True/False For i = 1 To iMaxAnswers If Mid(sGivenAnswer, i, 1) = "1" Then If Not IsNull(rsQuiz("ScoreAnswer" & i)) Then sScore = sScore + rsQuiz("ScoreAnswer" & i) End If Next Case 3 'Fill-In-The-Blank For i = 1 To iMaxAnswers If Not IsNull(rsQuiz("Answer" & i)) Then If UCase(sGivenAnswer) = UCase(rsQuiz("Answer" & i)) Then If Not IsNull(rsQuiz("ScoreAnswer" & i)) Then sScore = sScore + rsQuiz("ScoreAnswer" & i) End If End If Next End Select GetScore = sScore End Function Function GetEvaluation(sScore) 'Returns the evaluation, if any Dim sText Set rsEvaluation = Server.CreateObject("ADODB.Recordset") rsEvaluation.Open "SELECT * FROM Evaluation" & sWhereClause & " ORDER BY ID", cnnQuiz Do While Not rsEvaluation.EOF If rsEvaluation("LowerBound") <= sScore And rsEvaluation("UpperBound") >= sScore Then sText = rsEvaluation("Message") Exit Do End If rsEvaluation.MoveNext Loop rsEvaluation.Close Set rsEvaluation = Nothing 'Replace fields GetEvaluation = ReplaceFields(sText, sScore, "") End Function Sub PrintAnswerComment (sGivenAnswer, MyRs) Dim i, sTmp If MyRs("Type") = 0 Or MyRs("Type") = 1 Then 'Multiple choice, Multiple answer For i = 1 To Len(sGivenAnswer) If Mid(sGivenAnswer, i, 1) = "1" And MyRs("CommentAnswer" & i) <> "" And Not IsNull(MyRs("CommentAnswer" & i)) Then Response.Write "" & vbCrLf Response.Write "

" & MyRs("CommentAnswer" & i) & "" & vbCrLf Response.Write "" & vbCrLf End If Next End If End Sub Function MailMessage(sFrom, sTo, sBcc, sSubject, sBody) 'Sends an email message Dim iFormat If IsNull(sTo) Or sTo = "" Or sTo = ".." Then MailMessage = True Exit Function End If iFormat = 0 'Change here if needed If iFormat = 0 Then 'CDonts Set Mailer = Server.CreateObject("CDONTS.NewMail") Mailer.From = sFrom Mailer.To = sTo If Not (IsNull(sBcc) Or sBcc = "") Then Mailer.Bcc = sBcc Mailer.Subject = sSubject sBody = Replace(sBody, vbCrLf, "
") Mailer.Body = sBody Mailer.BodyFormat = 0 'HTML Mailer.MailFormat = 0 'Mime On Error Resume Next Mailer.Send MailMessage = Err.Number = 0 Set Mailer = Nothing ElseIf iFormat = 1 Then 'AspMail Set Mailer = Server.Createobject("SMTPsvg.Mailer") Mailer.FromName = sFrom Mailer.FromAddress = sFrom Mailer.RemoteHost = "" Mailer.AddRecipient sTo, sTo If Not (IsNull(sBcc) Or sBcc = "") Then Mailer.AddBCC sBcc, sBcc Mailer.Subject = sSubject sBody = Replace(sBody, vbCrLf, "
") Mailer.BodyText = sBody Mailer.ContentType = "text/html" MailMessage = Mailer.SendMail Set Mailer = Nothing ElseIf iFormat = 2 Then 'JMail Set Mailer = CreateObject ("JMail.SMTPMail") Mailer.ServerAddress = "" Mailer.Sender = sFrom Mailer.Subject = sSubject Mailer.AddRecipient sTo If Not (IsNull(sBcc) Or sBcc = "") Then Mailer.AddRecipientBcc sBcc sBody = Replace(sBody, vbCrLf, "
") Mailer.ContentType = "text/html" Mailer.Body = sBody Mailer.Execute Set Mailer = Nothing ElseIf iFormat = 3 Then 'SMTPmail Set Mailer = Server.Createobject("SoftArtisans.SMTPMail") Mailer.FromName = sFrom Mailer.FromAddress = sFrom Mailer.RemoteHost = "" Mailer.AddRecipient sTo, sTo If Not (IsNull(sBcc) Or sBcc = "") Then Mailer.AddBCC sBcc, sBcc Mailer.Subject = sSubject sBody = Replace(sBody, vbCrLf, "
") Mailer.BodyText = sBody Mailer.ContentType = "text/html" MailMessage = Mailer.SendMail Set Mailer = Nothing ElseIf iFormat = 4 Then 'AspEMail Set Mailer = Server.Createobject("Persits.MailSender") Mailer.FromName = sFrom Mailer.From = sFrom Mailer.Host = "" Mailer.AddAddress sTo, sTo If Not (IsNull(sBcc) Or sBcc = "") Then Mailer.AddBCC sBcc, sBcc Mailer.Subject = sSubject sBody = Replace(sBody, vbCrLf, "
") Mailer.Body = sBody Mailer.IsHTML = True On Error Resume Next Mailer.Send MailMessage = Err.Number = 0 Set Mailer = Nothing ElseIf iFormat = 5 Then 'Cdosys Set Mailer = Server.CreateObject("CDO.Message") Set objConfig = CreateObject("CDO.Configuration") objConfig.Fields("sendusing") = 2 objConfig.Fields("smtpserver") = "" objConfig.Fields("smtpport") = 25 objConfig.Fields.Update Set Mailer.Configuration = objConfig Mailer.From = sFrom Mailer.Subject = sSubject Mailer.To = sTo If Not (IsNull(sBcc) Or sBcc = "") Then Mailer.Bcc = sBcc sBody = Replace(sBody, vbCrLf, "
") Mailer.HTMLBody = sBody Mailer.Send Set Mailer = Nothing Set objConfig = Nothing ElseIf iFormat = 6 Then 'Cdosys (slighly different) Set Mailer = Server.CreateObject("CDO.Message") Set objConfig = CreateObject("CDO.Configuration") objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "" objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objConfig.Fields.Update Set Mailer.Configuration = objConfig Mailer.From = sFrom Mailer.Subject = sSubject Mailer.To = sTo If Not (IsNull(sBcc) Or sBcc = "") Then Mailer.Bcc = sBcc sBody = Replace(sBody, vbCrLf, "
") Mailer.HTMLBody = sBody Mailer.Send Set Mailer = Nothing Set objConfig = Nothing End If End Function Function ReplaceFields(sMessage, sScore, sEvaluation) 'Replace fields Dim sField, rsUserData, sDataValue, rsUser, i If MULTI_PAGE Then i = Instr(sMessage, ".") If i > 0 Then If Instr(i+1, sMessage, ".") > 0 Then 'Be sure we have at least two "." Set rsUserData = Server.CreateObject("ADODB.Recordset") Set rsUser = Server.CreateObject("ADODB.Recordset") rsUserData.Open "SELECT * FROM UserData" & sWhereClause, cnnQuiz, 1, 2 Do While Not rsUserData.EOF sField = "." & rsUserData("Name") & "." If Instr(1, sMessage, sField, 1) > 0 Then If iDBType = 0 Then rsUser.Open "SELECT * FROM Users WHERE ID=" & lUserID, cnnQuiz, 1, 2 sDataValue = rsUser("UD_" & rsUserData("Name")) Else rsUser.Open "SELECT * FROM UserDataValues WHERE UserID=" & lUserID & " AND UserDataID=" & rsUserData("ID"), cnnQuiz, 1, 2 If Not rsUser.EOF Then sDataValue = rsUser("ValueText") End If If IsNull(sDataValue) Then sDataValue = "" rsUser.Close sMessage = Replace(sMessage, sField, sDataValue, 1, -1, 1) End If rsUserData.MoveNext Loop rsUserData.Close Set rsUserData = Nothing Set rsUser = Nothing End If End If Else For Each i In Request.Form If Left(i,3) = "UD_" Then sField = "." & Right(i, Len(i) - 3) & "." sMessage = Replace(sMessage, sField, Request.Form(i), 1, -1, 1) End If Next End If sMessage = Replace(sMessage, ".SCORE.", sScore, 1, -1, vbTextCompare) sMessage = Replace(sMessage, ".EVALUATION.", sEvaluation, 1, -1, 1) ReplaceFields = sMessage End Function Sub OpenConnection(bShowHeader) 'Create connession to DB Set cnnQuiz = Server.CreateObject("ADODB.Connection") Set rsQuiz = Server.CreateObject("ADODB.Recordset") On Error Resume Next cnnQuiz.Open DB_CONNECTION_STRING If Err.Number <> 0 Then If bShowHeader Then PrintHeader "" Response.Write "

" & Replace(sLanguageString(6),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 End Sub Sub CloseConnection(rsQuiz, cnnQuiz) rsQuiz.Close Set rsQuiz = Nothing cnnQuiz.Close Set cnnQuiz = Nothing End Sub Sub PrintHeader(sString) Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "

" & vbCrLf Response.Write " " & vbCrLf Response.Write " " & vbCrLf Response.Write " " & vbCrLf Response.Write " " & vbCrLf Response.Write " " & vbCrLf Response.Write " " & vbCrLf Response.Write " " & vbCrLf Response.Write "

Quiz

" & vbCrLf End Sub Function GetOptionTags(sString) Dim sArray, i, sReturn, sItem sArray = Split(sString, ";") For i = 0 To UBound(sArray) sItem = sArray(i) sReturn = sReturn & "" Next GetOptionTags = sReturn End Function %> Quiz <% If ((Not MULTI_PAGE And iStatusID = 0) Or (MULTI_PAGE And iStatusID > 0)) And CInt(MAX_TIME) <> 0 Then %> <% bShowTimer = True iCurrentMaxTime = MAX_TIME If MULTI_PAGE And (iStatusID > 1 Or (iStatusID = 1 And iDirection = -1) Or (iStatusID = 1 And bShowCommentsNow)) Then iCurrentMaxTime = Sgn(MAX_TIME) * CLng(Request.Form("TimeElapsed")) End If %> <% End If %> <% 'Get Quiz ID If iDBType = 1 Then OpenConnection True On Error Resume Next rsQuiz.Open "SELECT * FROM Quizzes WHERE Active = 1 AND QuizTag='" & QUIZ_TAG & "'", cnnQuiz, 1, 2 If Err.Number <> 0 Then PrintHeader "" Response.Write "

" & Replace(sLanguageString(7),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If If Not rsQuiz.EOF Then iQuizID = rsQuiz("ID") Else PrintHeader "" Response.Write "

" & sLanguageString(8) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 CloseConnection rsQuiz, cnnQuiz sWhereClause = " WHERE QuizID = " & iQuizID End If %> <% 'Is private quiz? PRIVATE_QUIZ = IsPrivateQuiz() 'Total questions If QUESTIONS_TO_SHOW = -1 Then QUESTIONS_TO_SHOW = GetQuestionCount() 'Set cookie sCookieName = "TestAlreadyDone" & QUIZ_TAG bTestAlreadyDone = Session(sCookieName) Or Request.Cookies(sCookieName) = "1" If iStatusID = -1 And ALLOW_ONE_ACCESS And Not PRIVATE_QUIZ Then Session(sCookieName) = True Response.Cookies(sCookieName) = "1" Response.Cookies(sCookieName).Expires = DateAdd( "d", 1 ,Now) End If 'Check password CheckPassword() If PRIVATE_QUIZ Then CheckLogin() %> <% If bShowTimer And Not bShowCommentsNow Then sShowMsg = "true" If iStatusID > 1 Or (iStatusID = 1 And iDirection = -1) Or bShowCommentsNow Then sShowMsg = "false" sLoadString = " onLoad=""checkTime(" & sShowMsg & ")""" End If %> <% PrintHeader sLoadString %>

" onSubmit="return bUserPressedSubmit" style="margin-bottom:0;"> <% If bShowTimer Then Response.Write "" & vbCrLf %> <% Dim iCount, i, iResult, iScore, iQuestionNumber, bDoRedirect, iRecordCount, iQuizID Dim sSQLString, sTmp, sGivenAnswer, sQuestionsToShow, sComments, sWhereClause Dim cnnQuiz, rsQuiz OpenConnection False 'Retrieve questions If iStatusID = 0 Then 'First time 'Add new user to users table (save start time) On Error Resume Next rsQuiz.Open "SELECT * FROM Users" & sWhereClause, cnnQuiz, 1, 2 rsQuiz.AddNew If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(9),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If If iDBType = 1 Then rsQuiz("QuizID") = iQuizID rsQuiz("StartDate") = CDbl(DateAdd("n", TIME_ZONE, Now)) rsQuiz("IP") = Request.ServerVariables("REMOTE_ADDR") If PRIVATE_QUIZ Then 'Save data already available If iDBType = 0 Then For i = 0 To rsQuiz.Fields.Count - 1 If Left(rsQuiz.Fields(i).Name, 3) = "UD_" Then 'It's a custom field rsQuiz.Fields(i).Value = Session(rsQuiz.Fields(i).Name) End If Next Else 'Do nothing: we'll do it later End If End If rsQuiz.Update If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(10),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 If MULTI_PAGE Then iTmp = 1 Else iTmp = -1 End If If iDBType = 0 Then Response.Write "" & vbCrLf Else rsQuiz.Close rsQuiz.Open "SELECT @@IDENTITY FROM Users", cnnQuiz Response.Write "" & vbCrLf If PRIVATE_QUIZ Then 'Save data already available (we have not done it before) Set rsUserData = Server.CreateObject("ADODB.Recordset") rsUserData.Open "SELECT * FROM UserData" & sWhereClause, cnnQuiz Do While NOT rsUserData.EOF If Session("UD_" & rsUserData("Name")) <> "" Then cnnQuiz.Execute "INSERT INTO UserDataValues(UserDataID, UserID, ValueText) VALUES(" & rsUserData("ID") & "," & rsQuiz(0) & ",'" & Replace(Session("UD_" & rsUserData("Name")),"'","''") & "')" rsUserData.MoveNext Loop rsUserData.Close Set rsUserData = Nothing End If End If Response.Write "" & vbCrLf rsQuiz.Close sSQLString = "SELECT TOP " & QUESTIONS_TO_SHOW & " * FROM Questions" & sWhereClause If iDBType = 0 then If RANDOM_QUESTIONS Then sSQLString = sSQLString & " ORDER BY SIN([ID]*(CDbl(Time())*10000))" Else If RANDOM_QUESTIONS Then sSQLString = sSQLString & " ORDER BY NEWID()" End If Else 'See if already submitted On Error Resume Next rsQuiz.Open "SELECT * FROM Users WHERE ID=" & lUserID, cnnQuiz If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(11),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 Do While Not rsQuiz.EOF 'Always true If rsQuiz("EndDate") <> 0 Then Response.Write "

" & sLanguageString(12) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If rsQuiz.MoveNext Loop rsQuiz.Close If iStatusID = -1 Then 'Old user (save end time) On Error Resume Next If iDBType = 0 Then cnnQuiz.Execute "UPDATE Users SET EndDate = CDbl(DateAdd(""n""," & TIME_ZONE & ", Now)) WHERE ID=" & lUserID Else cnnQuiz.Execute "UPDATE Users SET EndDate = CONVERT(Float,DateAdd(""n""," & TIME_ZONE + 2880 & ", GetDate())) WHERE ID=" & lUserID End If If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(13),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 End If iArray = Split(Request.Form("QuestionsShown"), Chr(44)) If Not MULTI_PAGE Or iStatusID = -1 Then sSQLString = "SELECT * FROM Questions WHERE ID IN(" & Request.Form("QuestionsShown") & ")" Else sSQLString = "SELECT * FROM Questions WHERE ID = " & iArray(iStatusID - 1) End If iTmp = iStatusID + 1 Response.Write "" & vbCrLf Response.Write "" & vbCrLf End If 'Save given answers If ((iStatusID > 1 Or (iStatusID = 1 And iDirection = -1) Or (iStatusID = 1 And bShowCommentsNow)) And Request.Form("ShowingComments") = "") Or iStatusID = -1 Then sTotalScore = 0 On Error Resume Next If MULTI_PAGE Then If Request.Form("LastQuestion") <> "" Then iQuestionNumber = CInt(Request.Form("LastQuestion")) - 2 Else iQuestionNumber = iStatusID - 2 End If If iQuestionNumber = -3 Then iQuestionNumber = UBound(iArray) If iDirection = -1 Then iQuestionNumber = iQuestionNumber + 2 If bShowCommentsNow Then iQuestionNumber = iQuestionNumber + 1 rsQuiz.Open "SELECT * FROM Questions WHERE ID=" & iArray(iQuestionNumber), cnnQuiz iMax = 1 Else rsQuiz.Open sSQLString, cnnQuiz, 1 iMax = QUESTIONS_TO_SHOW End If If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(14),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 For i = 0 To iMax - 1 If Not MULTI_PAGE Then iQuestionNumber = i rsQuiz.Find "ID=" & iArray(iQuestionNumber),,,1 'Always finds one record End If sGivenAnswer = GetGivenAnswer(rsQuiz("Type"), iArray(iQuestionNumber), rsQuiz("MaxAnswers")) iResult = GetResult(sGivenAnswer, rsQuiz("RightAnswer"), rsQuiz("Type")) iScore = GetScore(iResult, rsQuiz("Type"), sGivenAnswer, rsQuiz("MaxAnswers")) If (SAVE_ANSWERS Or MULTI_PAGE) And Request.Form("ShowingComments") = "" Then sAnswerSQL = "INSERT INTO Answers (IDUser, IDQuestion, GivenAnswer, Result, Score) VALUES ('" & lUserID & "'," & iArray(iQuestionNumber) & ",'" & Replace(sGivenAnswer, "'", "''") & "', " & iResult & ", " & Replace(iScore, ",", ".") & ")" If MULTI_PAGE Then Set rsAnswer = Server.CreateObject("ADODB.Recordset") rsAnswer.Open "SELECT * FROM Answers WHERE IDUser=" & lUserID & " AND IDQuestion=" & iArray(iQuestionNumber), cnnQuiz, 1, 2 If Not rsAnswer.EOF Then sAnswerSQL = "UPDATE Answers SET GivenAnswer = '" & Replace(sGivenAnswer, "'", "''") & "', Result = " & iResult & ", Score = " & Replace(iScore, ",", ".") & " WHERE IDUser=" & lUserID & " AND IDQuestion=" & iArray(iQuestionNumber) rsAnswer.Close Set rsAnswer = Nothing End If On Error Resume Next cnnQuiz.Execute sAnswerSQL If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(15),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 End If 'Total score If MULTI_PAGE Then Set rsAnswer = Server.CreateObject("ADODB.Recordset") rsAnswer.Open "SELECT Sum(Score) FROM Answers WHERE IDUser=" & lUserID, cnnQuiz If IsNull(rsAnswer(0)) Then sTotalScore = iScore Else sTotalScore = rsAnswer(0) End If rsAnswer.Close Set rsAnswer = Nothing cnnQuiz.Execute "UPDATE Users SET Score = " & Replace(sTotalScore, ",", ".") & " WHERE ID=" & lUserID Else sTotalScore = sTotalScore + iScore End If Next rsQuiz.Close End If 'Get evaluation If iStatusID = -1 Then sTotalEvaluation = GetEvaluation(sTotalScore) 'Send email(s) If iStatusID = -1 Then Set rsEMails = Server.CreateObject("ADODB.Recordset") rsEMails.Open "SELECT * FROM EMails" & sWhereClause, cnnQuiz, 1, 2 Do While Not rsEMails.EOF 'Always true If rsEMails("sBody") <> "" And rsEMails("sTo") <> "" Then If iDBType = 0 Then i = rsEMails("ID") Else i = rsEMails("Type") End If If i = 2 Then 'Confirmation email bRetVal = MailMessage(rsEMails("sFrom"), ReplaceFields("." & rsEMails("sTo") & ".", sTotalScore, sTotalEvaluation), rsEMails("sBcc"), ReplaceFields(rsEMails("sSubject"), sTotalScore, sTotalEvaluation), ReplaceFields(rsEMails("sBody"), sTotalScore, sTotalEvaluation)) Else 'Notification email bRetVal = MailMessage(rsEMails("sFrom"), rsEMails("sTo"), rsEMails("sBcc"), ReplaceFields(rsEMails("sSubject"), sTotalScore, sTotalEvaluation), ReplaceFields(rsEMails("sBody"), sTotalScore, sTotalEvaluation)) End If End If rsEMails.MoveNext Loop rsEMails.Close Set rsEMails = Nothing End If 'Load messages Dim sQuizMessage(1), bShowMessage bShowMessage = MULTI_PAGE And iStatusID > 0 If bShowMessage Then bShowMessage = bShowMessage And iStatusID = UBound(iArray) + 1 If iStatusID = 0 Or bShowMessage Then 'Only if first time, otherwise do not show messages rsQuiz.Open "SELECT * FROM Messages" & sWhereClause, cnnQuiz, 1, 2 'Always finds 2 records If Not rsQuiz.EOF Then For i = 0 To 1 sQuizMessage(i) = rsQuiz("Message") If IsNull(sQuizMessage(i)) Then sQuizMessage(i) = "" rsQuiz.MoveNext Next End If rsQuiz.Close If MULTI_PAGE Then If iStatusID = 0 Then sQuizMessage(1) = "" Else sQuizMessage(0) = "" End If End If End If 'Start message If sQuizMessage(0) <> "" Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "

" & sQuizMessage(0) & "

" & vbCrLf End If 'Custom data If iStatusID = -1 Or iStatusID = 0 Or iStatusID = 1 Then On Error Resume Next rsQuiz.Open "SELECT * FROM UserData" & sWhereClause, cnnQuiz, 1, 2 If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(16),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 iRecordCount = 0 Do While Not rsQuiz.EOF If iDBType = 0 Then sCustomDataString = sCustomDataString & "UD_" & rsQuiz("Name") & " = '" & Replace(Request.Form("UD_" & rsQuiz("Name")), "'", "''") & "', " Else sCustomDataString = sCustomDataString & rsQuiz("ID") & "~" & Replace(Request.Form("UD_" & rsQuiz("Name")), "'", "''") & "¤ " End If rsQuiz.MoveNext iRecordCount = iRecordCount + 1 Loop If iRecordCount > 0 Then rsQuiz.MoveFirst If (iRecordCount > 0 Or iStatusID = -1) And Not iStatusID = 1 Then Response.Write "" & vbCrLf i = 0 Do While Not rsQuiz.EOF If i Mod 2 = 0 Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf sAnswersString = sAnswersString & rsQuiz("Label") & Chr(32) If iStatusID = 0 Then 'First time If PRIVATE_QUIZ And NO_USER_CHANGES And Session("UD_" & rsQuiz("Name")) <> "" Then Response.Write "" & vbCrLf Else If rsQuiz("Type") = 2 Then 'Combo Response.Write "" & vbCrLf Else Response.Write "" & vbCrLf End If End If Else If MULTI_PAGE Then Set rsUser = Server.CreateObject("ADODB.Recordset") If iDBType = 0 Then rsUser.Open "SELECT * FROM Users WHERE ID=" & lUserID, cnnQuiz, 1, 2 sDataValue = rsUser("UD_" & rsQuiz("Name")) Else sDataValue = "" rsUser.Open "SELECT * FROM UserDataValues WHERE UserID=" & lUserID & " AND UserDataID=" & rsQuiz("ID"), cnnQuiz, 1, 2 If Not rsUser.EOF Then sDataValue = rsUser("ValueText") End If If IsNull(sDataValue) Then sDataValue = "" rsUser.Close Set rsUser = Nothing Else sDataValue = Request.Form("UD_" & rsQuiz("Name")) End If Response.Write "" & vbCrLf sAnswersString = sAnswersString & sDataValue & "
" End If If i Mod 2 <> 0 Then Response.Write "" & vbCrLf If rsQuiz("Required") = 1 Then sRequiredCustomData = sRequiredCustomData & rsQuiz("Name") & Chr(32) If rsQuiz("Type") = 1 Then sEMailCustomData = sEMailCustomData & rsQuiz("Name") & Chr(32) i = i + 1 rsQuiz.MoveNext Loop If i Mod 2 <> 0 Then If iStatusID = 0 Or Not SHOW_TOTAL_SCORE Then 'First time or do not show score Response.Write "" & vbCrLf Else Response.Write "" & vbCrLf Response.Write "" & vbCrLf End If Response.Write "" & vbCrLf End If If iStatusID = -1 Then 'Not first time Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf If i Mod 2 = 0 And SHOW_TOTAL_SCORE Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf End If sAnswersString = sAnswersString & "IP: " & Request.ServerVariables("REMOTE_ADDR") & "
" & sLanguageString(21) & sTotalScore & "
" If sTotalEvaluation <> "" And SHOW_EVALUATION Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf sAnswersString = sAnswersString & sLanguageString(23) & sTotalEvaluation & "
" End If sAnswersString = sAnswersString & "

" End If Response.Write "

" & rsQuiz("Label") & "	" & Session("UD_" & rsQuiz("Name")) & "			" & sDataValue & "
	" & sLanguageString(17) & "	" & sTotalScore & "
" & sLanguageString(18) & "	" & FormatDateTime(DateAdd("n", TIME_ZONE, Now), vbGeneralDate) & "	" & sLanguageString(19) & "	" & Request.ServerVariables("REMOTE_ADDR") & "
" & sLanguageString(20) & "	" & sTotalScore & "
" & sLanguageString(22) & "	" & sTotalEvaluation & "

" & vbCrLf End If If iRecordCount < 1 And iStatusID = 0 And sQuizMessage(0) = "" And MULTI_PAGE Then bDoRedirect = True End If rsQuiz.Close End If 'Save evaluation, score and custom data If iStatusID = -1 Or (iStatusID = 1 And iDirection = 1) Then If Len(sCustomDataString) > 0 Then sCustomDataString = Left(sCustomDataString, Len(sCustomDataString) - 2) 'Delete last two chars On Error Resume Next If iStatusID = -1 Then If Len(sCustomDataString) > 0 And Not MULTI_PAGE Then If iDBType = 0 Then cnnQuiz.Execute "UPDATE Users SET Score = " & Replace(sTotalScore, ",", ".") & ", Evaluation = '" & Replace(sTotalEvaluation, "'", "''") & "', " & sCustomDataString & " WHERE ID=" & lUserID Else cnnQuiz.Execute "UPDATE Users SET Score = " & Replace(sTotalScore, ",", ".") & ", Evaluation = '" & Replace(sTotalEvaluation, "'", "''") & "' WHERE ID=" & lUserID sUserDataValues = Split(sCustomDataString, "¤") For i = 0 To UBound(sUserDataValues) sUserDataValuesDetails = Split(sUserDataValues(i), "~") rsQuiz.Open "SELECT * FROM UserDataValues WHERE UserID=" & lUserID & " AND UserDataID=" & sUserDataValuesDetails(0), cnnQuiz If rsQuiz.EOF Then rsQuiz.Close cnnQuiz.Execute "INSERT INTO UserDataValues(UserDataID, UserID, ValueText) VALUES(" & sUserDataValuesDetails(0) & "," & lUserID & ",'" & sUserDataValuesDetails(1) & "')" Else rsQuiz.Close cnnQuiz.Execute "UPDATE UserDataValues SET ValueText = '" & sUserDataValuesDetails(1) & "' WHERE UserID=" & lUserID & " AND UserDataID=" & sUserDataValuesDetails(0) End If Next End If Else cnnQuiz.Execute "UPDATE Users SET Score = " & Replace(sTotalScore, ",", ".") & ", Evaluation = '" & Replace(sTotalEvaluation, "'", "''") & "' WHERE ID=" & lUserID End If Else If iDBType = 0 Then If Len(sCustomDataString) > 0 And Not bShowCommentsNow Then cnnQuiz.Execute "UPDATE Users SET " & sCustomDataString & " WHERE ID=" & lUserID Else sUserDataValues = Split(sCustomDataString, "¤") For i = 0 To UBound(sUserDataValues) sUserDataValuesDetails = Split(sUserDataValues(i), "~") rsQuiz.Open "SELECT * FROM UserDataValues WHERE UserID=" & lUserID & " AND UserDataID=" & sUserDataValuesDetails(0), cnnQuiz If rsQuiz.EOF Then rsQuiz.Close cnnQuiz.Execute "INSERT INTO UserDataValues(UserDataID, UserID, ValueText) VALUES(" & sUserDataValuesDetails(0) & "," & lUserID & ",'" & sUserDataValuesDetails(1) & "')" Else rsQuiz.Close cnnQuiz.Execute "UPDATE UserDataValues SET ValueText = '" & sUserDataValuesDetails(1) & "' WHERE UserID=" & lUserID & " AND UserDataID=" & sUserDataValuesDetails(0) End If Next End If End If If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(24),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 End If 'Questions On Error Resume Next rsQuiz.Open sSQLString, cnnQuiz, 1 If Err.Number <> 0 Then Response.Write "

" & Replace(sLanguageString(25),"$ErrorMessage",Err.Description) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 If rsQuiz.EOF Then Response.Write "

" & sLanguageString(26) & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If If (MULTI_PAGE) And (iStatusID <> -1 ) And (iStatusID <> 0) Then iMax = 1 Else iMax = QUESTIONS_TO_SHOW End If For i = 0 To iMax - 1 If Not MULTI_PAGE Or iStatusID = -1 Then iQuestionNumber = i + 1 Else iQuestionNumber = iStatusID End If If MULTI_PAGE And (iStatusID = -1 Or iStatusID > 1 Or (iStatusID = 1 And iDirection = -1)) Then sSavedAnswer = "" Set rsAnswer = Server.CreateObject("ADODB.Recordset") rsAnswer.Open "SELECT * FROM Answers WHERE IDUser=" & lUserID & " AND IDQuestion=" & iArray(iQuestionNumber - 1), cnnQuiz, 1, 2 If Not rsAnswer.EOF Then sSavedAnswer = rsAnswer("GivenAnswer") If IsNull(sSavedAnswer) Then sSavedAnswer = "" End If rsAnswer.Close Set rsAnswer = Nothing End If If iStatusID = -1 Or bShowCommentsNow Then rsQuiz.Find "ID=" & iArray(iQuestionNumber - 1),,,1 'Always finds one record If bShowCommentsNow Or Not MULTI_PAGE Then sGivenAnswer = GetGivenAnswer(rsQuiz("Type"), iArray(iQuestionNumber - 1), rsQuiz("MaxAnswers")) Else sGivenAnswer = sSavedAnswer End If iResult = GetResult(sGivenAnswer, rsQuiz("RightAnswer"), rsQuiz("Type")) iScore = GetScore(iResult, rsQuiz("Type"), sGivenAnswer, rsQuiz("MaxAnswers")) If Not bShowCommentsNow Then If SEND_ANSWERS_EMAIL_FORMAT = 0 Or (SEND_ANSWERS_EMAIL_FORMAT = 1 And iResult = 2) Or SEND_ANSWERS_EMAIL_FORMAT = 2 Then sFullGivenAnswer = GetFullGivenAnswer(sGivenAnswer, rsQuiz) sAnswersString = sAnswersString & "" & sLanguageString(27) & iQuestionNumber & "
" sAnswersString = sAnswersString & Replace(rsQuiz("Question"),"

" sAnswersString = sAnswersString & "" & sLanguageString(28) & "
" sAnswersString = sAnswersString & Replace(sFullGivenAnswer,"

" If SEND_ANSWERS_EMAIL_FORMAT = 2 Then If IsNull(rsQuiz("RightAnswer")) Or rsQuiz("RightAnswer") = "" Then 'Do nothing Else sAnswersString = sAnswersString & "" & sLanguageString(29) & "
" sAnswersString = sAnswersString & Replace(GetFullGivenAnswer(rsQuiz("RightAnswer"), rsQuiz),"

" End If End If Response.Write "
" End If End If End If sComments = "" 'Says if one or more comments is attached to this question If MULTI_PAGE And iStatusID > 0 And SHOW_COMMENT_AFTER_ANSWER And Not bShowCommentsNow Then If GetTextFromField(rsQuiz("CommentRight")) <> "" Or GetTextFromField(rsQuiz("CommentWrong")) <> "" Or GetTextFromField(rsQuiz("CommentNull")) <> "" Then sComments = "1" End If End If Dim iArrayAnswers, sRequiredQuestions 'Used to reset If (iStatusID = -1 And Not SHOW_FULL_RESULTS) Or (MULTI_PAGE And iStatusID = 0) Then If MULTI_PAGE And iStatusID = 0 And RANDOM_ANSWERS Then If rsQuiz("Type") = 0 Or rsQuiz("Type") = 1 Then iArrayAnswers = GetAnswerNumbers(rsQuiz("MaxAnswers"), rsQuiz("MaxAnswers"), True) For iCount = 1 To 6 If iCount <= rsQuiz("MaxAnswers") Then sAnswersSequence = sAnswersSequence & iArrayAnswers(iCount - 1) Else sAnswersSequence = sAnswersSequence & "0" End If Next ElseIf rsQuiz("Type") = 2 Then sAnswersSequence = sAnswersSequence & "12" & String(4, "0") Else sAnswersSequence = sAnswersSequence & String(6, "0") End If End If Else If rsQuiz("Required") = 1 Then sRequiredQuestions = sRequiredQuestions & iQuestionNumber & Chr(44) & "q" & rsQuiz("ID") & Chr(44) & rsQuiz("Type") & Chr(44) & rsQuiz("MaxAnswers") & Chr(32) If sAnswersSequence <> "" Then Redim iArrayAnswers(rsQuiz("MaxAnswers") - 1) For iCount = 1 To rsQuiz("MaxAnswers") iArrayAnswers(iCount -1) = Mid(sAnswersSequence, iCount + (iQuestionNumber - 1) * 6, 1) Next Else iArrayAnswers = GetAnswerNumbers(rsQuiz("MaxAnswers"), rsQuiz("MaxAnswers"), RANDOM_ANSWERS And iStatusID <> -1 And Not bShowCommentsNow And (rsQuiz("Type") = 0 Or rsQuiz("Type") = 1)) End If Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "

" & iQuestionNumber & "

" & vbCrLf Response.Write "" & vbCrLf If Trim(rsQuiz("Picture")) <> "" Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf End If Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf If iStatusID = -1 Or bShowCommentsNow Then PrintAnswerComment sGivenAnswer, rsQuiz If (iStatusID = -1 Or bShowCommentsNow) And iResult = 1 And Trim(rsQuiz("CommentRight")) <> "" Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf End If If (iStatusID = -1 Or bShowCommentsNow) And iResult = 2 And Trim(rsQuiz("CommentWrong")) <> "" Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf End If If (iStatusID = -1 Or bShowCommentsNow) And iResult = 3 And Trim(rsQuiz("CommentNull")) <> "" Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf End If Response.Write "

" & rsQuiz("Question") & "

" & vbCrLf Response.Write "" & vbCrLf For iCount = 1 To rsQuiz("MaxAnswers") If MULTI_PAGE And iStatusID > 0 And SHOW_COMMENT_AFTER_ANSWER And (rsQuiz("Type") = 0 Or rsQuiz("Type") = 1) And Not bShowCommentsNow Then If GetTextFromField(rsQuiz("CommentAnswer" & iArrayAnswers(iCount - 1))) <> "" Then sComments = "1" End If End If If iStatusID = -1 Or bShowCommentsNow Then iWidth = 50 Else iWidth = 25 End If If rsQuiz("Type") <> 3 Then Response.Write "" & vbCrLf Next Response.Write "

" & vbCrLf Else Response.Write "

" & vbCrLf End If If iStatusID = -1 Or bShowCommentsNow Then 'Print result picture sTmp = GetResultPicture(iArrayAnswers(iCount - 1), sGivenAnswer, rsQuiz("RightAnswer"), rsQuiz("Type")) Response.Write " & Chr(34) & GetPictureTooltip(sTmp) & Chr(34) &

& Chr(34) & GetPictureTooltip(sTmp) & Chr(34) &

" sTmp = GetResultPicture2(iArrayAnswers(iCount - 1), sGivenAnswer, rsQuiz("RightAnswer"), rsQuiz("Type")) If Len(sTmp) > 0 Then Response.Write "

" Else 'Happens for Fill-In-The-Blank only Response.Write "" & sGivenAnswer & "" If SHOW_RIGHT_ANSWERS Then Response.Write "
" & rsQuiz("RightAnswer") & "" End If End If Else sChecked = "" Select Case rsQuiz("Type") Case 0, 2 'Multiple choice, True/False If MULTI_PAGE Then If Mid(sSavedAnswer, iArrayAnswers(iCount - 1), 1) = "1" Then sChecked = "checked" End If Response.Write "" Case 1 'Multiple answer If MULTI_PAGE Then If Mid(sSavedAnswer, iArrayAnswers(iCount - 1), 1) = "1" Then sChecked = "checked" End If Response.Write "" Case 3 'Fill-In-The-Blank If MULTI_PAGE Then If Len(sSavedAnswer) > 0 Then sChecked = sSavedAnswer End If If rsQuiz("Options") = 4 Then 'Essay Response.Write "" Else Response.Write "" If rsQuiz("Options") <> 0 Then sAnswersFormat = sAnswersFormat & CStr(rsQuiz("Options") - 1) & "q" & rsQuiz("ID") & Chr(32) End If End Select End If If rsQuiz("Type") <> 3 Then Response.Write "

" & vbCrLf Response.Write "" & rsQuiz("Answer" & iArrayAnswers(iCount - 1)) & "" End If Response.Write "

" & vbCrLf Response.Write "

" & rsQuiz("CommentRight") & "

" & rsQuiz("CommentWrong") & "

" & rsQuiz("CommentNull") & "

" & vbCrLf Response.Write "

" & vbCrLf End If If iStatusID = 0 Then sQuestionsToShow = sQuestionsToShow & rsQuiz("ID") & Chr(44) rsQuiz.MoveNext Else sQuestionsToShow = Request.Form("QuestionsShown") & Chr(44) End If Next 'Send answers by email If iStatusID = -1 Then If SEND_ANSWERS_EMAIL <> "" Then bRetVal = MailMessage(SEND_ANSWERS_EMAIL_FROM, SEND_ANSWERS_EMAIL, "", sLanguageString(30) & "Quiz", sAnswersString) End If End If 'End message If sQuizMessage(1) <> "" Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "

" & sQuizMessage(1) & "

" & vbCrLf End If 'Write hidden fields If iStatusID <> -1 Then Response.Write "" & vbCrLf If sAnswersSequence <> "" Then Response.Write "" & vbCrLf If MAX_TIME <> 0 Then Response.Write "" & vbCrLf If MULTI_PAGE Then Response.Write "" & vbCrLf If sComments <> "" And Not bShowCommentsNow Then Response.Write "" & vbCrLf If bShowCommentsNow Then Response.Write "" & vbCrLf End If CloseConnection rsQuiz, cnnQuiz %> <% If iStatusID = -1 Then %> <% If SHOW_PRINT_BUTTON Then %> <% End If %> <% Else %> <% If MULTI_PAGE Then %> <% If iStatusID = 0 Then %> <% ElseIf iStatusID >= 1 Then %> <% Else %> <% End If %> <% End If %> <% Else %> <% End If %> <% End If %>


			<% If Not bShowCommentsNow Then %> <% End If %> <% If Not NO_BACK_BUTTON And iStatusID > 1 Then %> <% End If %> <% If (iStatusID = UBound(iArray) + 1) And Not (sComments <> "" And Not bShowCommentsNow) Then %>