qestionpaper.cls

Visual Basic管理信息系统开发 学生考试系统(源代码)

        DataEnv.rsQstPaper.Fields("Score") = Score
        DataEnv.rsQstPaper.Update
        AddQuestion = True
    End If
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
End Function

Public Function Create() As Boolean  '创建试卷
    On Error Resume Next
    If Created Then          '如果已经创建过试卷，则该创建失败
        Create = False
        Exit Function
    End If
    DataEnv.DelQuestion     '执行数据环境命令DelQuestion
    Dim iCount As Long
    Dim QID As Long
    Dim Score As Single
    
    For iCount = 1 To FillingNum
       QID = GetQID(1, Score)   '从填空题库中随机获取题目编号
       AddQuestion iCount, QID, 1, Score   '将获取的题目添加到试卷中
    Next
    
    For iCount = 1 To RightWrongNum
       QID = GetQID(2, Score)   '从判断题库中随机获取题目编号
       AddQuestion iCount + FillingNum, QID, 2, Score  '将获取的题目添加到试卷中
    Next
    For iCount = 1 To SingleSelNum
       QID = GetQID(3, Score)  '从单选题库中随机获取题目编号
       AddQuestion iCount + FillingNum + RightWrongNum, QID, 3, Score  '将获取的题目添加到试卷中
    Next
    For iCount = 1 To MultiSelNum
       QID = GetQID(4, Score)  '从多选题库中随机获取题目编号
       AddQuestion iCount + FillingNum + RightWrongNum + SingleSelNum, QID, 4, Score  '将获取的题目添加到试卷中
    Next
    For iCount = 1 To EssayQuesNum
       QID = GetQID(5, Score)  '从问答题库中随机获取题目编号
       AddQuestion iCount + FillingNum + RightWrongNum + SingleSelNum + MultiSelNum, QID, 5, Score  '将获取的题目添加到试卷中
    Next
    Created = True
    Create = True
End Function
Public Function GetQuestionID(ByVal QSerial As Long) As Long  '获取试卷编号QSerail的题目编号
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial = " & CStr(QSerial)
    If DataEnv.rsQstPaper.RecordCount < 1 Then
        GetQuestionID = 0
    Else
        GetQuestionID = DataEnv.rsQstPaper.Fields("QuestionID")
    End If
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
End Function

Public Function GetQuestion(ByVal QSerial As Long) As String  '获取试卷编号QSerail的题目问题
    On Error Resume Next
    Dim dbrs As ADODB.Recordset
    Dim QType As QuestionType
    Dim QID As Long
    QID = GetQuestionID(QSerial)
    QType = GetType(QSerial)
    Set dbrs = GetDBRS(QType)
    dbrs.Open
    dbrs.Filter = "QuestionID = " & CStr(QID)
    GetQuestion = CStr(QSerial) & ". " & dbrs.Fields("Question")
    dbrs.Filter = ""
    dbrs.Close
End Function
Public Function GetChoice(ByVal QSerial As Long) As String  '获取试卷编号QSerail的题目选项
    On Error Resume Next
    Dim dbrs As ADODB.Recordset
    Dim QType As QuestionType
    Dim QID As Long
    Dim S As String
    Dim i As Byte
    QType = GetType(QSerial)
    If QType <> singlesel And QType <> MultiSel Then  '如果试题类型不是单选题或多选题
        GetChoice = ""                                '返回值为空字符串
        Exit Function
    End If
    QID = GetQuestionID(QSerial)                      '获取题目编号
    Set dbrs = GetDBRS(QType)                         '获取试题库数据集
    dbrs.Open
    dbrs.Filter = "QuestionID = " & CStr(QID)
    S = ""
    For i = 1 To 3         '将各个选项拼接为以逗号分隔的字符串
        S = S & dbrs.Fields("Choice" & CStr(i)) & ","
    Next
    S = S & dbrs.Fields("Choice4")
    dbrs.Filter = ""
    dbrs.Close
    GetChoice = S
End Function

Public Function DelQuestion(ByVal PSerial As Long) As Boolean   '删除一个问题
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial = " & PSerial
    DataEnv.rsQstPaper.Delete adAffectCurrent
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
End Function

Public Sub ReportToFile(ByVal FileName As String)  '将试卷输出到文件
    On Error Resume Next
    Dim txtFile As String
    Dim iCount As Long
    If Dir(FileName, vbNormal) <> "" Then    '如果文件已经存在，则删除原文件
        Kill FileName
    End If
    Open FileName For Output As #1          '打开文件用于写入数据
    Print #1, "    试卷样稿    "
    Print #1, "------------------"
    For iCount = 1 To LastQSerial          '输出每道题目
        txtFile = GetQuestion(iCount)      '获取每道题的题目问题
        If txtFile <> "" Then
            Print #1, txtFile
        End If
        txtFile = GetChoice(iCount)        '获取并输出题目选项
        If txtFile <> "" Then
            Dim S() As String
            S = Split(txtFile, ",")        '利用逗号分隔符将获取的字符串分割为字符串数组
            Dim i As Byte
            For i = 0 To UBound(S)         '输出数组元素
                txtFile = Space(3) & Chr(Asc("A") + i) & "." & S(i)
                Print #1, txtFile
            Next
        End If
    Next
Close #1
End Sub

Public Function GetType(ByVal QSerial As Long) As QuestionType  '获取试卷编号为QSerial的题目类型
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial = " & CStr(QSerial)  '查找相应的记录
    If DataEnv.rsQstPaper.RecordCount < 1 Then
        GetType = OnErr
    Else
        Dim iType As Byte
        iType = DataEnv.rsQstPaper.Fields("QuestionType")  '获取"QuestionType"字段
        GetType = iType
    End If
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    
End Function
Public Function GetQSerial(ByVal nCount As Long) As Long   '参数nCount表数据集中的第几条记录
    On Error Resume Next
    DataEnv.rsQstPaper.Open                                '打开数据集
    If DataEnv.rsQstPaper.RecordCount < nCount Then        '如果数据集为空，则返回值为0
        GetQSerial = 0
    Else
        DataEnv.rsQstPaper.Move nCount - 1, 0              '将游标移到第nCount条记录
        GetQSerial = DataEnv.rsQstPaper.Fields("PaperSerial") '获取PaperSerial字段值
    End If
    DataEnv.rsQstPaper.Close                               '关闭数据集
End Function

Public Function GetQAnswer(ByVal QSerial As Long) As String '获取试卷编号为QSerial题目的参考答案
    Dim dbrs As ADODB.Recordset
    Dim QType As QuestionType
    Dim QID As Long
    QType = GetType(QSerial)   '确定试题的类型
    QID = GetQuestionID(QSerial)  '获取问题的编号
    Set dbrs = GetDBRS(QType)    '获取试题库的数据集
    dbrs.Open
    dbrs.Filter = "QuestionID = " & CStr(QID)  '在试题库中查询其所对应的试题
    GetQAnswer = dbrs.Fields("Answer")   '获取试题的参考答案
    dbrs.Filter = ""
    dbrs.Close
End Function

Public Function GetUserAnswer(ByVal QSerial As Long) As String '获取试卷编号为QSerial的用户答案
    Dim UserAnswer
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial =" & CStr(QSerial)
    If DataEnv.rsQstPaper.RecordCount < 1 Then
        GetUserAnswer = ""
    Else
        UserAnswer = DataEnv.rsQstPaper.Fields("UserAnswer")
        If IsNull(UserAnswer) Then
            GetUserAnswer = ""
        Else
            GetUserAnswer = DataEnv.rsQstPaper.Fields("UserAnswer")
        End If
    End If
    DataEnv.rsQstPaper.Close
End Function

Public Sub Check(ByVal QSerial As Long)  '评阅试卷编号为QSerial的试题
    On Error Resume Next
    Dim uAnswer As String
    Dim qAnswer As String
    uAnswer = GetUserAnswer(QSerial)
    qAnswer = GetQAnswer(QSerial)
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial = " & CStr(QSerial)
    If uAnswer = qAnswer Then
        DataEnv.rsQstPaper.Fields("Commence") = DataEnv.rsQstPaper.Fields("Score")
    Else
        DataEnv.rsQstPaper.Fields("Commence") = 0
    End If
    DataEnv.rsQstPaper.Close
End Sub

Public Sub SetAnswer(ByVal iCount As Long, ByVal Answer As String)  '设置用户答案
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Move iCount - 1, 0
    DataEnv.rsQstPaper.Fields("UserAnswer") = Answer
    DataEnv.rsQstPaper.Update   '更新数据集
    DataEnv.rsQstPaper.Close
End Sub