<% DB_NAME = "/mdb-database/TCoviello/smwq_vzan_d1.mdb" SAVE_ANSWERS = True QUESTIONS_TO_SHOW = 25 RANDOM_QUESTIONS = True RANDOM_ANSWERS = True PASSWORD = "LEGAME" ALLOW_ONE_ACCESS = True MAX_TIME = -1800 NO_BACK_BUTTON = False PRIVATE_QUIZ = True NO_USER_CHANGES = True SEND_ANSWERS_EMAIL_FROM = "" SEND_ANSWERS_EMAIL = "" SHOW_RIGHT_ANSWERS = False SHOW_FULL_RESULTS = False SHOW_TOTAL_SCORE = True SHOW_EVALUATION = False SHOW_COMMENT_AFTER_ANSWER = False MULTI_PAGE = False CreditString = "


Creato e gestito con SmartLite WebQuiz XP " '--- Do not edit below this line --- iTimeOut = (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 If iStatusID <> 0 And ALLOW_ONE_ACCESS And Not PRIVATE_QUIZ Then sCookieName = "TestAlreadyDoneRLVQM" bTestAlreadyDone = Session(sCookieName) Or Request.Cookies(sCookieName) = "1" Session(sCookieName) = True Response.Cookies(sCookieName) = "1" Response.Cookies(sCookieName).Expires = DateAdd( "d", 1 ,Now) End If 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 "

  Password:
" & vbCrLf Response.Write "   " & vbCrLf 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 "

  Impossibile continuare: le risposte possono essere inviate una sola volta.

" & vbCrLf Response.End End If End Function Function CheckLogin() Dim sSQL, i, bAlreadyDone 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("TestLoggedInUserRLVQM") & "' AND Pass='" & Session("TestLoggedInPasswordRLVQM") & "'" rsQuiz.Open sSQL, cnnQuiz , 1, 2 Else sSQL = "SELECT * FROM AllowedUsers WHERE Username='" & Request.Form("TestUserName") & "' AND Pass='" & Request.Form("TestPassword") & "'" rsQuiz.Open sSQL, cnnQuiz , 1 End If If rsQuiz.RecordCount > 0 Then bAlreadyDone = rsQuiz("LastRun") <> "" If iStatusID = -1 Then rsQuiz("LastRun") = Now rsQuiz.Update Else Session("TestLoggedInUserRLVQM") = Request.Form("TestUserName") Session("TestLoggedInPasswordRLVQM") = Request.Form("TestPassword") For i = 0 To rsQuiz.Fields.Count - 1 Session(rsQuiz.Fields(i).Name) = rsQuiz.Fields(i).Value Next End If End If CloseConnection rsQuiz, cnnQuiz End If If Session("TestLoggedInUserRLVQM") = "" Then PrintHeader "" Response.Write "

" & vbCrLf Response.Write "  Utente:
  
" & vbCrLf Response.Write "  Password:
   " & vbCrLf Response.Write "

" & vbCrLf Response.Write "" & vbCrLf Response.End End If If ALLOW_ONE_ACCESS And bAlreadyDone Then 'User accessed the quiz more than one time PrintHeader "" Response.Write "

  Impossibile continuare: il test può essere svolto una sola volta.

" & vbCrLf Session("TestLoggedInUserRLVQM") = "" Response.End End If If iStatusID = -1 Then Session("TestLoggedInUserRLVQM") = "" 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 = "Esatta" Case "fail.gif" GetPictureTooltip = "Errata" 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 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 End If End Function Function ReplaceFields(sMessage, sScore, sEvaluation) 'Replace fields Dim sField 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, vbTextCompare) End If Next sMessage = Replace(sMessage, ".SCORE.", sScore, 1, -1, vbTextCompare) sMessage = Replace(sMessage, ".EVALUATION.", sEvaluation, 1, -1, vbTextCompare) ReplaceFields = sMessage End Function Sub OpenConnection(bShowHeader) sDbConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DB_NAME) & ";" 'Create connession to DB Set cnnQuiz = Server.CreateObject("ADODB.Connection") Set rsQuiz = Server.CreateObject("ADODB.Recordset") On Error Resume Next cnnQuiz.Open sDbConnectionString If Err.Number <> 0 Then If bShowHeader Then PrintHeader "" Response.Write "

  Impossibile caricare le domande. Il database non è stato trovato oppure la connessione al database non è riuscita. Messaggio di errore: " & 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 "
I legami chimici
" & vbCrLf End Sub %> I legami chimici <% 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 %> <% 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 Dim sDbConnectionString, sSQLString, sTmp, sGivenAnswer, sQuestionsToShow, sComments 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 "Users", cnnQuiz, 1, 2, 2 rsQuiz.AddNew If Err.Number <> 0 Then Response.Write "

  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: " & Err.Description & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If rsQuiz("StartDate") = CDbl(Now) rsQuiz("IP") = Request.ServerVariables("REMOTE_ADDR") If PRIVATE_QUIZ Then 'Save data already available 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 End If rsQuiz.Update If Err.Number <> 0 Then Response.Write "

  Impossibile caricare le domande. Il database potrebbe essere bloccato. Attendere alcuni minuti e riprovare. Messaggio di errore: " & Err.Description & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 If MULTI_PAGE Then iTmp = 1 Else iTmp = -1 End If Response.Write "" & vbCrLf Response.Write "" & vbCrLf rsQuiz.Close sSQLString = "SELECT TOP " & QUESTIONS_TO_SHOW & " * FROM Questions" If RANDOM_QUESTIONS Then sSQLString = sSQLString & " ORDER BY SIN([ID]*(CDbl(Time())*10000))" 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 "

  Impossibile salvare le risposte. Il database potrebbe essere bloccato. Attendere alcuni minuti e riprovare. Messaggio di errore: " & 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 "

  Impossibile continuare: le risposte sono già state inviate.

" 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 cnnQuiz.Execute "UPDATE Users SET EndDate = CDbl(Now) WHERE ID=" & lUserID If Err.Number <> 0 Then Response.Write "

  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: " & 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 "

  Impossibile salvare le risposte. Il database potrebbe essere bloccato oppure l'amministratore potrebbe avere cancellato la tua utenza. Messaggio di errore: " & 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 rsAnswer.RecordCount > 0 Then sAnswerSQL = "UPDATE Answers SET GivenAnswer = '" & Replace(sGivenAnswer, "'", "''") & "', Result = " & iResult & ", Score = " & Replace(iScore, ",", ".") & " WHERE IDUser=" & lUserID & " AND IDQuestion=" & iArray(iQuestionNumber) End If rsAnswer.Close Set rsAnswer = Nothing End If On Error Resume Next cnnQuiz.Execute sAnswerSQL If Err.Number <> 0 Then Response.Write "

  Impossibile salvare le risposte. Il database potrebbe essere bloccato oppure l'amministratore potrebbe avere cancellato la tua utenza. Messaggio di errore: " & 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 "EMails", cnnQuiz, 1, 2, 2 Do While Not rsEMails.EOF 'Always true If rsEMails("sBody") <> "" And rsEMails("sTo") <> "" Then If rsEMails("ID") = 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 "Messages", cnnQuiz, 1, 2, 2 For i = 0 To 1 sQuizMessage(i) = rsQuiz("Message") If IsNull(sQuizMessage(i)) Then sQuizMessage(i) = "" rsQuiz.MoveNext Next 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 "UserData", cnnQuiz, 1, 2, 2 If Err.Number <> 0 Then Response.Write "

  Impossibile caricare le domande. Il database potrebbe essere bloccato. Attendere alcuni minuti e riprovare. Messaggio di errore: " & Err.Description & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 Do While Not rsQuiz.EOF sCustomDataString = sCustomDataString & "UD_" & rsQuiz("Name") & " = '" & Replace(Request.Form("UD_" & rsQuiz("Name")), "'", "''") & "', " rsQuiz.MoveNext Loop If rsQuiz.RecordCount > 0 Then rsQuiz.MoveFirst If (rsQuiz.RecordCount > 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 Response.Write "" & vbCrLf End If Else If MULTI_PAGE Then Set rsUser = Server.CreateObject("ADODB.Recordset") rsUser.Open "SELECT * FROM Users WHERE ID=" & lUserID, cnnQuiz, 1, 2 sDataValue = rsUser("UD_" & rsQuiz("Name")) 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") & "
" & "Punteggio: " & sTotalScore & "
" If sTotalEvaluation <> "" And SHOW_EVALUATION Then Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf Response.Write "" & vbCrLf sAnswersString = sAnswersString & "Valutazione: " & sTotalEvaluation & "
" End If sAnswersString = sAnswersString & "

" End If Response.Write "
" & rsQuiz("Label") & "  " & Session("UD_" & rsQuiz("Name")) & "" & sDataValue & "
 Punteggio:  " & sTotalScore & "
Data:  " & FormatDateTime(Now, vbGeneralDate) & "IP:  " & Request.ServerVariables("REMOTE_ADDR") & "
Punteggio:  " & sTotalScore & " 
Valutazione:  " & sTotalEvaluation & "
" & vbCrLf End If If rsQuiz.RecordCount < 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 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 End If Else If Len(sCustomDataString) > 0 Then cnnQuiz.Execute "UPDATE Users SET " & sCustomDataString & " WHERE ID=" & lUserID End If If Err.Number <> 0 Then Response.Write "

  Impossibile salvare le risposte. Il database potrebbe essere bloccato oppure l'amministratore potrebbe avere cancellato la tua utenza. Messaggio di errore: " & 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 "

  Impossibile caricare le domande. Il database potrebbe essere bloccato. Attendere qualche minuto e riprovare. Messaggio di errore: " & Err.Description & "

" CloseConnection rsQuiz, cnnQuiz Response.End End If On Error Goto 0 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 rsAnswer.RecordCount > 0 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 sFullGivenAnswer = GetFullGivenAnswer(sGivenAnswer, rsQuiz) sAnswersString = sAnswersString & "Domanda " & iQuestionNumber & "
" sAnswersString = sAnswersString & Replace(rsQuiz("Question"),"" sAnswersString = sAnswersString & "Risposta data" & "
" sAnswersString = sAnswersString & Replace(sFullGivenAnswer,"
" 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) & " 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 "" 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, "", "Risposte dal quiz: I legami chimici", 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 MULTI_PAGE Then Response.Write "" & vbCrLf If MAX_TIME <> 0 Then Response.Write "" & vbCrLf End If If sComments <> "" And Not bShowCommentsNow Then Response.Write "" & vbCrLf If bShowCommentsNow Then Response.Write "" & vbCrLf End If CloseConnection rsQuiz, cnnQuiz %> <% If iStatusID = -1 Then %> <% Else %> <% If MULTI_PAGE Then %> <% If iStatusID = 0 Then %> <% ElseIf iStatusID = 1 Then %> <% Else %> <% End If %> <% ElseIf iStatusID > 1 Then %> <% Else %> <% End If %> <% End If %> <% Else %> <% End If %> <% End If %>
 
  <% If Not bShowCommentsNow Then %> <% End If %> <% If (iStatusID = UBound(iArray) + 1) And Not (sComments <> "" And Not bShowCommentsNow) Then %> <% If Not bShowCommentsNow Then %> <% End If %> <% If Not NO_BACK_BUTTON Then %> <% End If %> <% If (iStatusID = UBound(iArray) + 1) And Not (sComments <> "" And Not bShowCommentsNow) Then %>  
<% =CreditString %>