frmselecttest.frm

上机考试系统

        With objProFill
            n = Int(Rnd * .RecordCount + 1) '随机产生一个记录号
            '获得试题编号
            .MoveFirst
            .Move n - 1, adBookmarkFirst
            n = .Fields("编号")
            '检查试题编号是否重复
            For j = 1 To i - 1
                If iProFill(j) = n Then Exit For
            Next
            If j < i Then
                i = i - 1           '重新抽取题号
            Else
                '检查选中题的填空数
                m = 0
                For j = 1 To 4
                    If .Fields("空" & Chr(j + 96)) <> "" Then m = m + 1
                Next
                If iPFS(m - 2) < Val(txtDivSum(m + 1)) Then
                    iProFill(s) = n       '保存未重复的题号
                    s = s + 1
                    iPFS(m - 2) = iPFS(m - 2) + 1
                    i = i + m - 1
                Else
                    i = i - 1             '重新抽取题号
                End If
            End If
        End With
    Next
    '打开手工选题窗口，显示已选试题
    For i = 1 To Val(txtSum(0))
        TestDIY.lstJudge.AddItem Trim(Str(iJudge(i)))
    Next
    For i = 1 To Val(txtSum(1))
        TestDIY.lstSelOne.AddItem Trim(Str(iSelOne(i)))
    Next
    For i = 1 To Val(txtSum(2))
        If iProRead(i) = 0 Then Exit For
        TestDIY.lstProRead.AddItem Trim(Str(iProRead(i)))
    Next
    i = 1
    For i = 1 To Val(txtSum(3))
        If iProFill(i) = 0 Then Exit For
        TestDIY.lstProFill.AddItem Trim(Str(iProFill(i)))
    Next
    Me.Hide                             '隐藏试卷定制窗体
    TestDIY.Show                        '显示手工选题窗体
    cmdSave.Enabled = True
End Sub

Private Sub cmdClear_Click()
    Dim i%
    txtName = ""
    isSaved = False
    cmdSave.Enabled = False
End Sub

Private Sub cmdDiy_Click()
    Dim i%, s%
    '检验试题设置是否正确
    If Check_Seting() = False Then Exit Sub
    '根据小题数量定义数组大小
    ReDim Preserve iJudge(Val(txtSum(0)))
    ReDim Preserve iSelOne(Val(txtSum(1)))
    ReDim Preserve iProRead(Val(txtSum(2)))
    ReDim Preserve iProFill(Val(txtSum(3)))
    '显示手工选题窗口
    For i = 1 To Val(txtSum(0))
        If iJudge(i) = 0 Then Exit For
        TestDIY.lstJudge.AddItem Trim(Str(iJudge(i)))
    Next
    For i = 1 To Val(txtSum(1))
        If iSelOne(i) = 0 Then Exit For
        TestDIY.lstSelOne.AddItem Trim(Str(iSelOne(i)))
    Next
    For i = 1 To Val(txtSum(2))
        If iProRead(i) = 0 Then Exit For
        TestDIY.lstProRead.AddItem Trim(Str(iProRead(i)))
    Next
    i = 1
    For i = 1 To Val(txtSum(3))
        If iProFill(i) = 0 Then Exit For
        TestDIY.lstProFill.AddItem Trim(Str(iProFill(i)))
    Next
    Me.Hide                             '隐藏试卷定制窗体
    TestDIY.Show                        '显示手工选题窗体
    cmdSave.Enabled = True
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdSave_Click()
    '检查是否根据设置选择了试题
    Dim i%
    On Error GoTo DealError
    Dim strSQL$
    If iJudge(1) = 0 Then
        MsgBox "没有根据设置选择试题！", vbCritical, Me.Caption
    ElseIf Trim(txtName) = "" Then
        MsgBox "请输入试题名称！", vbCritical, Me.Caption
        txtName.SetFocus
        txtName = ""
    Else
        With objCn
            If .State = adStateClosed Then .Open
            If Not isSaved Then
                '创建试题库，保存试题
                strSQL = "Create Table " & Trim(txtName) _
                   & " ( 编号 int not null, 题型  varchar(8) not null, 分数 tinyint not null)"
                .Execute strSQL
                strSQL = "INSERT INTO 历届试题 (表名) VALUES ('" & Trim(txtName) & "')"
                .Execute strSQL
            Else
                If MsgBox("是否重新保存试题？", vbQuestion + _
                          vbYesNo, Me.Caption) = vbYes Then
                    '删除原有试题
                    strSQL = "delete " & Trim(txtName) & " "
                    .Execute strSQL
                Else
                    .Close
                    Exit Sub
                End If
            End If
            '保存试题
            For i = 1 To UBound(iJudge)
                If iJudge(i) = 0 Then Exit For
                strSQL = "INSERT INTO " & Trim(txtName) & _
                     " (编号,题型,分数) VALUES (" & Str(iJudge(i)) & ",'判断题'," _
                     & txtScore(0) & ")"
                .Execute strSQL
            Next
            For i = 1 To UBound(iSelOne)
                If iSelOne(i) = 0 Then Exit For
                strSQL = "INSERT INTO " & Trim(txtName) & _
                         " (编号,题型,分数) VALUES (" & Str(iSelOne(i)) & ",'选择题'," _
                        & txtScore(1) & ")"
                .Execute strSQL
            Next
            For i = 1 To UBound(iProRead)
                If iProRead(i) = 0 Then Exit For
                strSQL = "INSERT INTO " & Trim(txtName) & _
                         " (编号,题型,分数) VALUES (" & Str(iProRead(i)) & ",'程序阅读'," _
                     & txtScore(2) & ")"
                .Execute strSQL
            Next
            For i = 1 To UBound(iProFill)
                If iProFill(i) = 0 Then Exit For
                strSQL = "INSERT INTO " & Trim(txtName) & _
                         " (编号,题型,分数) VALUES (" & Str(iProFill(i)) & ",'程序填空'," _
                     & txtScore(3) & ")"
                .Execute strSQL
            Next
            MsgBox "成功保存试题！"
            '刷新往届试题列表
            Set objOld.ActiveConnection = objCn
            If objOld.State = adStateClosed Then objOld.Open
            objOld.Requery
            cmbOld.Clear
            cmbOld.AddItem ""
            If objOld.RecordCount > 0 Then
                objOld.MoveFirst
                While Not objOld.EOF
                    cmbOld.AddItem objOld.Fields("表名")
                    objOld.MoveNext
                Wend
            End If
            isSaved = True
            If .State = adStateOpen Then .Close
        End With
    End If
    Exit Sub
DealError:
    '处理可能产生的错误
    If Err.Number = -2147217900 Then
        MsgBox "程序执行出错：请修改试题名称后再尝试保存操作！", vbCritical, Me.Caption
        txtName.SetFocus
        If objCn.State = adStateOpen Then objCn.Close
        If objOld.State = adStateOpen Then objOld.Close
    Else
        MsgBox Err.Description, vbCritical, Me.Caption
        If objCn.State = adStateOpen Then objCn.Close
        If objOld.State = adStateOpen Then objOld.Close
    End If
End Sub

Private Sub Form_Load()
    With objCn                                 '建立数据库联接
        .Provider = "SQLOLEDB"
        .ConnectionString = "User ID=sa;PWD=123;Data Source=(local);Initial Catalog=自测考试"
        .Open
    End With
    '访问数据库获得判断题数据
    Set objJudge = New Recordset                '实例化对象
    With objJudge
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .CursorType = adOpenStatic              '指定使用静态游标
        .Open "SELECT * FROM 判断题"            '获取判断题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得单项选择题数据
    Set objSelOne = New Recordset                '实例化对象
    With objSelOne
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .CursorType = adOpenStatic              '指定使用静态游标
        .Open "SELECT * FROM 选择题"            '获取选择题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得程序阅读题数据
    Set objProRead = New Recordset                '实例化对象
    With objProRead
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .CursorType = adOpenStatic              '指定使用静态游标
        .Open "SELECT * FROM 程序阅读"          '获取程序阅读题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得程序填空题数据
     Set objProFill = New Recordset                '实例化对象
    With objProFill
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .CursorType = adOpenStatic              '指定使用静态游标
        .Open "SELECT * FROM 程序填空"          '获取程序填空题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
    End With
    '访问数据库获得历届试题数据
    Set objOld = New Recordset                '实例化对象
    With objOld
        Set .ActiveConnection = objCn           '建立数据库连接
        .CursorLocation = adUseClient           '指定使用客户端游标
        .CursorType = adOpenStatic              '指定使用静态游标
        .Open "SELECT * FROM 历届试题"          '获取历届试题数据
        Set .ActiveConnection = Nothing         '断开数据库连接
        cmbOld.AddItem ""
        If .RecordCount > 0 Then
            .MoveFirst
            While Not .EOF
                cmbOld.AddItem .Fields("表名")
                .MoveNext
            Wend
        End If
    End With
    objCn.Close                                 '关闭数据库连接
End Sub

Private Sub Form_Unload(Cancel As Integer)
    '释放数据库连接和记录集对象
    Set objCn = Nothing
    Set objOld = Nothing
    Set objJudge = Nothing
    Set objSelOne = Nothing
    Set objProRead = Nothing
    Set objProFill = Nothing
End Sub

Private Sub txtScore_Change(Index As Integer)
    If Val(txtSum(Index)) <> 0 Then
        txtScores(Index) = Val(txtSum(Index)) * Val(txtScore(Index))
    End If
End Sub
Private Sub txtSum_Change(Index As Integer)
    If Val(txtScore(Index)) <> 0 Then
        txtScores(Index) = Val(txtSum(Index)) * Val(txtScore(Index))
    End If
End Sub
'检验小题分值输入
Private Sub txtScore_KeyPress(Index As Integer, KeyAscii As Integer)
    If Not (Chr(KeyAscii) Like "[0-9]" Or KeyAscii = vbKeyBack) Then
        KeyAscii = 0    '输入不是数字或退格键，取消输入
    End If
End Sub
'检验小题数量输入
Private Sub txtSum_KeyPress(Index As Integer, KeyAscii As Integer)
    If Not (Chr(KeyAscii) Like "[0-9]" Or KeyAscii = vbKeyBack) Then
        KeyAscii = 0    '输入不是数字或退格键，取消输入
    End If
End Sub
'检验总分输入
Private Sub txtTotalScore_KeyPress(KeyAscii As Integer)
    If Not (Chr(KeyAscii) Like "[0-9]" Or KeyAscii = vbKeyBack) Then
        KeyAscii = 0    '输入不是数字或退格键，取消输入
    End If
End Sub

'判断题数据访问属性过程
Public Property Get Judge() As Variant
    Judge = iJudge
End Property
Public Property Let Judge(iNew As Variant)
    iJudge = iNew
End Property
'选择题数据访问属性过程
Public Property Get SelOne() As Variant
    SelOne = iSelOne
End Property
Public Property Let SelOne(iNew As Variant)
    iSelOne = iNew
End Property
'程序阅读题题数据访问属性过程
Public Property Get ProRead() As Variant
    ProRead = iProRead
End Property
Public Property Let ProRead(iNew As Variant)
    iProRead = iNew
End Property
'程序填空题数据访问属性过程
Public Property Get ProFill() As Variant
    ProFill = iProFill
End Property
Public Property Let ProFill(iNew As Variant)
    iProFill = iNew
End Property

Private Function Check_Seting() As Boolean
    Dim i%, s%
    Check_Seting = False
    '检查是否正确的设置了各类型题的小题数和分数
    For i = 0 To 3
        If Val(txtSum(i)) = 0 Then
            MsgBox "请设置正确的小题数量！", vbCritical, Me.Caption
            txtSum(i).SetFocus
            Exit Function
        ElseIf Val(txtScore(i)) = 0 Then
            MsgBox "请设置正确的小题分数！", vbCritical, Me.Caption
            txtScore(i).SetFocus
            Exit Function
        End If
        s = s + Val(txtScores(i))
    Next
    '检查小题分数合计与总分是否一致
    If Val(txtTotalScore) <> Val(s) Then
        MsgBox "小题分数合计与试卷总分不一致！", vbCritical, Me.Caption
        Exit Function
    End If
    '检验程序阅读分题干数设置是否正确
    If Val(txtDivSum(0)) + Val(txtDivSum(1)) * 2 + Val(txtDivSum(2)) * 3 <> Val(txtSum(2)) Then
        MsgBox "程序阅读题分题干数设置不正确！", vbCritical, Me.Caption
        txtDivSum(0).SetFocus
        Exit Function
    End If
    '检验程序填空题分题干数设置是否正确
    If Val(txtDivSum(3)) * 2 + Val(txtDivSum(4)) * 3 + Val(txtDivSum(5)) * 4 <> Val(txtSum(3)) Then
        MsgBox "程序填空题分题干数设置不正确！", vbCritical, Me.Caption
        txtDivSum(3).SetFocus
        Exit Function
    End If
    Check_Seting = True
End Function