frmtoscoring.frm

自测考试系统

            frmBlank(3).Visible = False
        End If
    End With
    '显示填空题答题情况
    optYN1(0) = False
    optYN1(1) = False
    If iRight(iTestNo) = 1 Then
        optYN1(0) = True
    ElseIf iRight(iTestNo) = 0 Then
        optYN1(1) = True
    End If
    optYN2(0) = False
    optYN2(1) = False
    If iRight(iTestNo + 1) = 1 Then
        optYN2(0) = True
    ElseIf iRight(iTestNo + 1) = 0 Then
        optYN2(1) = True
    End If
    optYN3(0) = False
    optYN3(1) = False
    If iRight(iTestNo + 2) = 1 Then
        optYN3(0) = True
    ElseIf iRight(iTestNo + 2) = 0 Then
        optYN3(1) = True
    End If
    optYN4(0) = False
    optYN4(1) = False
    If iRight(iTestNo + 3) = 1 Then
        optYN4(0) = True
    ElseIf iRight(iTestNo + 3) = 0 Then
        optYN4(1) = True
    End If
Else
   If cmbtype.ListIndex = 1 Then
       Frame2.Visible = False
       Frame3.Visible = True
       Frame1.Caption = "问答题及参考答案"
       Select Case Index
        Case 0                  '使第一题成为当前题
            If iTestNo <> 0 Then iTestNo = 0
        Case 1                  '使上一题成为当前题
            iTestNo = iTestNo - 1
            If iTestNo < 0 Then iTestNo = 0
        Case 2                  '使下一个记录成为当前题
            iTestNo = iTestNo + 1
            If iTestNo > UBound(strTest1) Then iTestNo = UBound(strTest1)
        Case 3                  '使最后一题成为当前题
            iTestNo = UBound(strTest1)
    End Select
    n = InStr(strTest1(iTestNo), "=")
    code1 = Left(strTest1(iTestNo), n - 1)
    answer1 = Mid(strTest1(iTestNo), n + 1)
    txtStuAnswer1 = answer1
    oldfs(iTestNo) = Val(txtscoreans.Text)
    s = s + Val(txtscoreans.Text)
    txtscore(4) = s
    'If iTestNo = 0 And iTestNo <= UBound(strTest1) + 1 Then
    'fsans = fsans + Val(txtscoreans.Text)
    'txtscore(4) = fsans
    'End If
   ' If InStr(p, iTestNo) Then
    'p = p & Str(iTestNo)
    'q = Val(txtscoreans.Text)
   ' l = l + q
   ' Else
    
    '显示问答题及参考答案
    With objanswer
        .MoveFirst
        .Find "编号=" & code1
        txttest = "【" & Trim(Str(iTestNo + 1)) & "】" & vbCrLf _
                & .Fields("题干") & vbCrLf & "参考答案：" & .Fields("答案")
    End With
    End If
End If
End Sub

Private Sub cmdSubmit_Click()
Dim i%, j%, k%
    Dim strSQL$
    i = Val(txtscore(0)) + Val(txtscore(1)) + Val(txtscore(2)) + Val(txtscore(3)) + Val(txtscore(4))
    If MsgBox("本试卷总分：" & Str(i) & "，提交？", vbQuestion + vbYesNo, _
               "教师阅卷") = vbNo Then Exit Sub
    '保存当前学生试卷成绩
    strSQL = "update 学生信息 set 成绩=" & Str(i) _
            & " where 考号='" & StuCode & "'"
    objCn.Execute strSQL
    '保存阅卷记录
    strSQL = "Insert Into 阅卷记录 (教师,考号) Values (" _
             & Str(objTeacher.Fields("编号")) & ",'" & StuCode & "')"
    objCn.Execute strSQL
    MsgBox "成绩提交成功！", vbInformation, "教师阅卷"
    '更新教师阅卷信息
    lblTotal = "剩余份数：" & Str(Val(Mid(lblTotal, 6)) - 1)
    lblChecked = "已阅份数：" & Str(Val(Mid(lblChecked, 6)) + 1)
    txtNum = Str(Val(txtNum) + 1)
    '获得下一份试卷
    With objTest
         .Close
         Set .ActiveConnection = objCn                   '建立数据库连接
        .Open "SELECT TOP 1 考试记录.* FROM 考试记录,学生信息 " _
                & " WHERE 考试记录.考号=学生信息.考号 and 成绩 is null"
        Set .ActiveConnection = Nothing                  '断开数据库连接
        If .RecordCount = 0 Then
            MsgBox "试卷已经评阅完毕！"
            picNavigation.Enabled = False
            cmdSubmit.Enabled = False
            Exit Sub
        End If
        StuCode = .Fields("考号")
    End With
    Get_Test_Data
    iTestNo = 0
    ReDim iRight(UBound(strTest))
    '设置默认值
    For i = 0 To UBound(strTest)
        iRight(i) = -1
    Next
    cmdMove(0).Value = True
End Sub

Private Sub Form_Load()
   Dim i%
    Set objCn = New Connection
    With objCn                                 '建立数据库联接
        .Provider = "SQLOLEDB"
        .ConnectionString = "User ID=sa;Data Source=(local);Initial Catalog=自测考试"
        .Open
    End With
    '访问数据库获得判断题数据
    Set objjudge = New Recordset                '实例化对象
    With objjudge
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .Open "SELECT * FROM 判断题"            '获取判断题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得单项选择题数据
    Set objselone = New Recordset                '实例化对象
    With objselone
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .Open "SELECT * FROM 单项选择题"        '获取单项选择题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得多项选择题数据
    Set objselmany = New Recordset                '实例化对象
    With objselmany
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .Open "SELECT * FROM 多项选择题"        '获取多项选择题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得填空题数据
    Set objfill = New Recordset                 '实例化对象
    With objfill
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .Open "SELECT * FROM 填空题"            '获取填空题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
        iffs = .Fields("分数")
    End With
    '访问数据库获得问答题数据
     Set objanswer = New Recordset                '实例化对象
    With objanswer
         Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .Open "SELECT * FROM 问答题"            '获取问答题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得第一份批改试卷数据
    Set objTest = New Recordset                '实例化对象
    With objTest
        Set .ActiveConnection = objCn                   '建立数据库连接
        .CursorLocation = adUseClient                   '指定使用客户端游标
       .Open "SELECT TOP 1 考试记录.* FROM 考试记录,学生信息 " _
                & " WHERE 考试记录.考号=学生信息.考号 and 成绩 is null"
        Set .ActiveConnection = Nothing                  '断开数据库连接
        If .RecordCount = 0 Then
            MsgBox "试卷已经评阅完毕！"
            Frame2.Enabled = False
            picNavigation.Enabled = False
            cmdSubmit.Enabled = False
            Exit Sub
        End If
        StuCode = .Fields("考号")
    End With
    '访问数据库获得阅卷教师信息
    Set objTeacher = New Recordset                '实例化对象
    With objTeacher
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .Open "SELECT * FROM 阅卷教师 where 姓名='" & currentusername & "'"          '获得阅卷教师信息
        Set .ActiveConnection = Nothing         '断开数据库连接
        If .RecordCount = 0 Then
            MsgBox "请以阅卷教师身份登录系统，否则不能正常使用阅卷功能！", , Me.Caption
            Frame2.Enabled = False
            picNavigation.Enabled = False
            cmdSubmit.Enabled = False
            Exit Sub
        End If
        frmTeacher.Caption = currentusername & "阅卷信息"
        lblTotal = "剩余份数：" & .Fields("数量")
        lblChecked = "已阅份数：0"
        txtNum = "1"
    End With
    '显示试卷填空题和问答题以及客观分数
    Get_Test_Data
    iTestNo = 0
    ReDim iRight(UBound(strTest))
    '设置默认值
    For i = 0 To UBound(strTest)
        iRight(i) = -1
    Next
    ReDim oldfs(UBound(strTest1))
    cmbtype.ListIndex = 0
    cmdMove(0).Value = True
End Sub
'自定义过程get_test_date来显示试卷程序填空以及客观分数，其代码如下：
Private Sub Get_Test_Data()
    Dim msg$, i%, code$, answer$, iScore%, iTotal%, n%, m%
    Dim code1$, answer1$, code2$, answer2$, Code3$, Answer3$
    '统计判断题应得分数
    strTest = Split(objTest.Fields("判断题"), Chr(13) & Chr(10))
    iScore = objjudge("分数")
    For i = 0 To UBound(strTest)
        n = InStr(1, strTest(i), "=")
        code = Left(strTest(i), n - 1)
        answer = Mid(strTest(i), n + 1)
        With objjudge
            .MoveFirst
            .Find "编号=" & code
            If (answer = "TRUE" And .Fields("答案") = True) Or _
                    (answer = "FALSE" And .Fields("答案") = False) Then
                iTotal = iTotal + iScore
            End If
        End With
    Next i
    txtscore(0) = iTotal
    '统计单项选择题应得分数
    strTest = Split(objTest.Fields("单选题"), Chr(13) & Chr(10))
    iScore = objselone("分数")
    iTotal = 0
    For i = 0 To UBound(strTest)
        n = InStr(1, strTest(i), "=")
        code = Left(strTest(i), n - 1)
        answer = Mid(strTest(i), n + 1)
        With objselone
            .MoveFirst
            .Find "编号=" & code
            If answer = .Fields("答案") Then
                iTotal = iTotal + iScore
            End If
        End With
    Next i
    txtscore(1) = iTotal
     '统计多项选择题应得分数
    strTest = Split(objTest.Fields("多选题"), Chr(13) & Chr(10))
    iScore = objselmany("分数")
    iTotal = 0
    For i = 0 To UBound(strTest)
        n = InStr(1, strTest(i), "=")
        code = Left(strTest(i), n - 1)
        answer = Mid(strTest(i), n + 1)
        With objselmany
            .MoveFirst
            .Find "编号=" & code
            'answer = Right(.Fields("答案"), Len(.Fields("答案")) - 1)
            If Right(answer, Len(answer) - 1) = .Fields("答案") Then
                iTotal = iTotal + iScore
            End If
        End With
    Next i
    txtscore(2) = iTotal
    '获得填空题
    strTest = Split(objTest.Fields("填空题"), Chr(13) & Chr(10))
     '获得问答题
    strTest1 = Split(objTest.Fields("问答题"), Chr(13) & Chr(10))
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set objCn = Nothing
    Set objjudge = Nothing
    Set objTest = Nothing
    Set objselone = Nothing
    Set objselmany = Nothing
    Set objfill = Nothing
    Set objanswer = Nothing
End Sub

Private Sub optYN1_Click(Index As Integer)
    If Index = 0 And iRight(iTestNo) <> 1 Then
        iRight(iTestNo) = 1
    ElseIf Index = 1 Then
        iRight(iTestNo) = 0
    End If
    Sum_Score
End Sub

Private Sub optYN2_Click(Index As Integer)
 If Index = 0 And iRight(iTestNo + 1) <> 1 Then
        iRight(iTestNo + 1) = 1
    ElseIf Index = 1 Then
        iRight(iTestNo + 1) = 0
    End If
End Sub

Private Sub optYN3_Click(Index As Integer)
 If Index = 0 And iRight(iTestNo + 2) <> 1 Then
        iRight(iTestNo + 2) = 1
    ElseIf Index = 1 Then
        iRight(iTestNo + 2) = 0
    End If
    Sum_Score
End Sub

Private Sub optYN4_Click(Index As Integer)
 If Index = 0 And iRight(iTestNo + 3) <> 1 Then
        iRight(iTestNo + 3) = 1
    ElseIf Index = 1 Then
        iRight(iTestNo + 3) = 0
    End If
    Sum_Score
End Sub
Private Sub Sum_Score()
    Dim i%, s%
    For i = 0 To UBound(iRight)
        If iRight(i) = 1 Then s = s + iffs
    Next
    txtscore(3) = s
End Sub