qestionpaper.cls

这是一个可以用于毕业设计的计算机等级考试模拟系统。管理员能够从题库中抽题来完成命题等工作。非常实用。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "QestionPaper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
Private mvarFillingNum As Long
Private mvarSingleSelNum As Long
Private mvarAnswered As Boolean
Private mvarChecked As Boolean

Public Property Get SingleSelScore() As Single
    On Error Resume Next
    Dim SSScore As Single
    Dim a As Integer
    a = 1
    SSScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType ='" & a & "'And PaperID='" & Paper & "'"
    While Not DataEnv.rsQstPaper.EOF
        SSScore = SSScore + DataEnv.rsQstPaper.Fields("Commence")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    SingleSelScore = SSScore
End Property '选择题实得的分数

Public Property Get FillingScore() As Single
    On Error Resume Next
    Dim FScore As Single
    Dim a As Integer
    a = 2
    FScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType ='" & a & "'And PaperID='" & Paper & "'"
    While Not DataEnv.rsQstPaper.EOF
        FScore = FScore + DataEnv.rsQstPaper.Fields("Commence")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    FillingScore = FScore
End Property '填空题实得的分数

Public Property Get SScore() As Single
    On Error Resume Next
    Dim SSScore As Single
    Dim a As Integer
    a = 1
    SSScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType ='" & a & "'And PaperID='" & Paper & "'"
    While Not DataEnv.rsQstPaper.EOF
        SSScore = SSScore + DataEnv.rsQstPaper.Fields("Score")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    SScore = SSScore
End Property '选择题应得的分数

Public Property Get FScore() As Single
    On Error Resume Next
    Dim SSScore As Single
    Dim a As Integer
    a = 2
    SSScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType ='" & a & "'And PaperID='" & Paper & "'"
    While Not DataEnv.rsQstPaper.EOF
        SSScore = SSScore + DataEnv.rsQstPaper.Fields("Score")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    FScore = SSScore
End Property '填空题应得的分数

Public Property Get QuestionNum() As Long
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperID=" & Paper
    QuestionNum = DataEnv.rsQstPaper.RecordCount
    DataEnv.rsQstPaper.Close
End Property '此函数用于获得试卷中试题的数量

Public Property Get LastQSerial() As Long
    LastQSerial = GetQSerial(QuestionNum)
End Property

Public Property Get FirstQSerial() As Long
    FirstQSerial = GetQSerial(1)
End Property

Public Property Let FillingNum(ByVal vData As Integer)
    mvarFillingNum = vData
End Property

Public Property Get FillingNum() As Integer
    FillingNum = mvarFillingNum
End Property

Public Property Let SingleSelNum(ByVal vData As Integer)
    mvarSingleSelNum = vData
End Property

Public Property Get SingleSelNum() As Integer
    SingleSelNum = mvarSingleSelNum
End Property

Public Property Let Answered(ByVal vData As Boolean)
    mvarAnswered = vData
End Property

Public Property Get Answered() As Boolean
    Answered = mvarAnswered
End Property

Public Property Let Checked(ByVal vData As Boolean)
    mvarChecked = vData
End Property

Public Property Get Checked() As Boolean
    Checked = mvarChecked
End Property

Private Function GetDBRS(ByVal QType As QuestionType) As ADODB.Recordset
    On Error Resume Next
    Select Case QType
      Case filling
          Set GetDBRS = DataEnv.rsFillingQ
      Case singlesel
          Set GetDBRS = DataEnv.rsSingleSelQ
      Case Else
          Set GetDBRS = Nothing
    End Select
End Function '此函数用于设置数据集为选择题或填空题

Public Function AddQuestion(ByVal iCount As Long, ByVal QID As Long, ByVal QType As QuestionType, ByVal Score As Single) As Boolean
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionID = '" & CStr(QID) & "' and QuestionType = '" & CStr(QType) & "'and PaperId='" & Paper & "'"
    If DataEnv.rsQstPaper.RecordCount > 0 Then
        AddQuestion = False
    Else
        DataEnv.rsQstPaper.Filter = ""
        DataEnv.rsQstPaper.AddNew
        DataEnv.rsQstPaper.Fields("PaperID") = Paper
        DataEnv.rsQstPaper.Fields("PaperSerial") = iCount
        DataEnv.rsQstPaper.Fields("QuestionID") = QID
        DataEnv.rsQstPaper.Fields("QuestionType") = QType
        DataEnv.rsQstPaper.Fields("Score") = Score
        DataEnv.rsQstPaper.Update
        AddQuestion = True
    End If
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    End Function '此函数用于题库维护时从题库向试卷中添加试题

Public Function GetQuestionID(ByVal QSerial As Long) As Long
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial = '" & QSerial & "'And PaperID='" & Paper & "'"
    If DataEnv.rsQstPaper.RecordCount < 1 Then
        GetQuestionID = 0
    Else
        GetQuestionID = DataEnv.rsQstPaper.Fields("QuestionID")
      End If
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
End Function '此函数用于获得试卷中题号为QSerial的题在相应题库中的ID值

Public Function GetQuestion(ByVal QSerial As Long) As String
    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 '此函数用于获得试卷中题号为QSerial的题的问题

Public Function GetChoice(ByVal QSerial As Long) As String
    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 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 '此函数用于获得试卷中题号为QSerial的选择题的四个被选项

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 '此函数用于在题库维护时删除试卷中题号为QSerial的题的问题

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
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial ='" & CStr(QSerial) & "'And PaperID ='" & Paper & "'"
    If DataEnv.rsQstPaper.RecordCount < 1 Then
        GetType = OnErr
    Else
        Dim iType As Byte
        iType = DataEnv.rsQstPaper.Fields("QuestionType")
        GetType = iType
    End If
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    End Function '此函数用于获得试卷中题号为QSerial的题的类型

Public Function GetQSerial(ByVal nCount As Long) As Long
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperID =" & Paper
    If DataEnv.rsQstPaper.RecordCount < nCount Then
        GetQSerial = 0
    Else
        DataEnv.rsQstPaper.Move nCount - 1, 0
        GetQSerial = DataEnv.rsQstPaper.Fields("PaperSerial")
    End If
    DataEnv.rsQstPaper.Close
End Function '此函数用于获得试卷中第nCount个题在相应试卷中的题号

Public Function GetQAnswer(ByVal QSerial As Long) As String
    Dim dbrs As ADODB.Recordset
    Dim QType As QuestionType
    Dim QID As Long
    QType = GetType(QSerial)
    QID = GetQuestionID(QSerial)
    Select Case QType
      Case filling
          Set dbrs = DataEnv.rsFillingQ
      Case singlesel
          Set dbrs = DataEnv.rsSingleSelQ
    End Select
    dbrs.Open
    dbrs.Filter = "QuestionID = " & CStr(QID)
    GetQAnswer = dbrs.Fields("Answer")
    dbrs.Filter = ""
    dbrs.Close
End Function '此函数用于获得试卷中题号为QSerial的题的答案

Public Function GetUserAnswer(ByVal QSerial As Long) As String
    Dim UserAnswer As String
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial ='" & CStr(QSerial) & "'and PaperID ='" & Paper & "'"
    If DataEnv.rsQstPaper.RecordCount < 1 Then
        GetUserAnswer = ""
    Else
        UserAnswer = DataEnv.rsQstPaper.Fields("UserAnswer")
        If IsNull(UserAnswer) Then
            GetUserAnswer = ""
        Else
            GetUserAnswer = UserAnswer
        End If
    End If
    DataEnv.rsQstPaper.Close
End Function '此函数用于获得试卷中题号为QSerial的题的考生答案

Public Sub Check(ByVal QSerial As Long)
    Dim uAnswer As String
    Dim qAnswer As String
    uAnswer = GetUserAnswer(QSerial)
    qAnswer = GetQAnswer(QSerial)
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperSerial ='" & CStr(QSerial) & "'And PaperID='" & Paper & "'"
    If uAnswer = qAnswer Then
        DataEnv.rsQstPaper.Fields("Commence") = DataEnv.rsQstPaper.Fields("Score")
    Else
        DataEnv.rsQstPaper.Fields("Commence") = 0
    End If
End Sub '此函数用于评判试卷

Public Sub SetAnswer(ByVal iCount As Long, ByVal Answer As String)
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "PaperID =" & Paper
    DataEnv.rsQstPaper.Move iCount - 1, 0
    DataEnv.rsQstPaper.Fields("UserAnswer") = Answer
    DataEnv.rsQstPaper.Update
    DataEnv.rsQstPaper.Close
End Sub '此函数用于向试卷库中保存考生的答案