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 mvarRightWrongNum As Long
Private mvarSingleSelNum As Long
Private mvarMultiSelNum As Long
Private mvarEssayQNum As Long
Private mvarCreated As Boolean
Private mvarAnswered As Boolean
Private mvarChecked As Boolean

Public Property Get SubjectiveScore() As Single
    On Error Resume Next
    Dim SubScore As Single
    SubScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType = 1 or QuestionType = 5"
    While Not DataEnv.rsQstPaper.EOF
        SubScore = SubScore + DataEnv.rsQstPaper.Fields("Commence")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    SubjectiveScore = SubScore
End Property

Public Property Get ObjectiveScore() As Single
    On Error Resume Next
    Dim objScore As Single
    objScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType = 2 or QuestionType = 3 Or QuestionType = 4"
    While Not DataEnv.rsQstPaper.EOF
        objScore = objScore + DataEnv.rsQstPaper.Fields("Commence")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    ObjectiveScore = objScore
End Property

Public Property Get SScore() As Single
    On Error Resume Next
    Dim SubScore As Single
    SubScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType = 1 or QuestionType = 5"
    While Not DataEnv.rsQstPaper.EOF
        SubScore = SubScore + DataEnv.rsQstPaper.Fields("Score")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    SScore = SubScore

End Property

Public Property Get OScore() As Single
    On Error Resume Next
    Dim objScore As Single
    objScore = 0
    DataEnv.rsQstPaper.Open
    DataEnv.rsQstPaper.Filter = "QuestionType = 2 or QuestionType = 3 Or QuestionType = 4"
    While Not DataEnv.rsQstPaper.EOF
        objScore = objScore + DataEnv.rsQstPaper.Fields("Score")
        DataEnv.rsQstPaper.MoveNext
    Wend
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    OScore = objScore
End Property

Public Property Get QuestionNum() As Long
    DataEnv.rsQstPaper.Open
    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 RightWrongNum(ByVal vData As Integer)
    mvarRightWrongNum = vData
End Property

Public Property Get RightWrongNum() As Integer
    RightWrongNum = mvarRightWrongNum
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 MultiSelNum(ByVal vData As Integer)
    mvarMultiSelNum = vData
End Property

Public Property Get MultiSelNum() As Integer
    MultiSelNum = mvarMultiSelNum
End Property

Public Property Let EssayQuesNum(ByVal vData As Integer)
    mvarEssayQNum = vData
End Property

Public Property Get EssayQuesNum() As Integer
    EssayQuesNum = mvarEssayQNum
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 Created(ByVal vData As Boolean)
    mvarCreated = vData
End Property

Public Property Get Created() As Boolean
    Created = mvarCreated
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 Blacks
          Set GetDBRS = DataEnv.rsFillingQ
      Case RightOrWrong
          Set GetDBRS = DataEnv.rsRorWQ
      Case singlesel
          Set GetDBRS = DataEnv.rsSingleSelQ
      Case MultiSel
          Set GetDBRS = DataEnv.rsMultiSelQ
      Case EssayQuestion
          Set GetDBRS = DataEnv.rsEssayQ
      Case Else
          Set GetDBRS = Nothing
    End Select
End Function
Private Function GetQID(ByVal QType As QuestionType, ByRef Score As Single) As Long
    On Error Resume Next
    Dim dbrs As ADODB.Recordset
    Set dbrs = GetDBRS(QType)
    Dim QstID As Long
    QstID = 0
    dbrs.Open
    DataEnv.rsQstPaper.Open
    While (QstID = 0)
        Randomize
        QstID = Int(Rnd * (dbrs.RecordCount - 1))
        dbrs.Move QstID, adBookmarkFirst
        QstID = dbrs.Fields("QuestionID")
        Score = dbrs.Fields("Score")
        DataEnv.rsQstPaper.Filter = "QuestionID = " & QstID & " And QuestionType =" & QType
        If DataEnv.rsQstPaper.RecordCount > 0 Then
            QstID = 0
        End If
    Wend
    DataEnv.rsQstPaper.Close
    dbrs.Close
    GetQID = QstID
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)
    If DataEnv.rsQstPaper.RecordCount > 0 Then
        AddQuestion = False
    Else
        DataEnv.rsQstPaper.Filter = ""
        DataEnv.rsQstPaper.AddNew
        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 Create() As Boolean
    On Error Resume Next
    If Created Then
        Create = False
        Exit Function
    End If
    DataEnv.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
    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
    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
    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
    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")
        GetType = iType
    End If
    DataEnv.rsQstPaper.Filter = ""
    DataEnv.rsQstPaper.Close
    
End Function
Public Function GetQSerial(ByVal nCount As Long) As Long
    On Error Resume Next
    DataEnv.rsQstPaper.Open
    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

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)
    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
    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)
    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