frmselecttest.frm

自测考试系统

     Check_Seting = True
End Function


Private Sub Cmbold_Click()
Dim iTotal%, objtemp As New Recordset, m%, j%, i%
Dim sj$, sso$, ssm$, sfl$, sans$, vj, vso, vsm, vfl, vans
If Cmbold.ListIndex > 0 Then
'清除窗体中的原有数据
For i = 0 To 4
txtsum(i) = "": txtscore(i) = ""
Next
For i = 0 To 3
txtdiv(i) = ""
Next
'访问数据库,获得选中试卷的试题数据
If objCn.State = adStateClosed Then objCn.Open
With objtemp
     Set .ActiveConnection = objCn
         .CursorLocation = adUseClient
         .CursorType = adOpenStatic
         .Open "select * from " & Cmbold
     If .RecordCount > 0 Then
        .MoveFirst
        While Not .EOF
             Select Case .Fields("题型")
                    Case "判断题"
                          txtscore(0) = Trim(Str(.Fields("分数")))
                          txtsum(0) = Trim(Str(Val(txtsum(0)) + 1))
                          sj = sj & "," & Trim(Str(.Fields("编号")))
                    Case "单选题"
                          txtscore(1) = Trim(Str(.Fields("分数")))
                          txtsum(1) = Trim(Str(Val(txtsum(1)) + 1))
                          sso = sso & "," & Trim(Str(.Fields("编号")))
                    Case "多选题"
                          txtscore(2) = Trim(Str(.Fields("分数")))
                          txtsum(2) = Trim(Str(Val(txtsum(2)) + 1))
                          ssm = ssm & "," & Trim(Str(.Fields("编号")))
                    Case "问答题"
                          txtscore(3) = Trim(Str(.Fields("分数")))
                          txtsum(3) = Trim(Str(Val(txtsum(3)) + 1))
                          sans = sans & "," & Trim(Str(.Fields("编号")))
                    Case "填空题"
                          txtscore(4) = Trim(Str(.Fields("分数")))
                    '计算选中的填空数
                    objFill.MoveFirst
                    objFill.Find "编号=" & Str(.Fields("编号"))
                    m = 0
                    For j = 1 To 4
                    If objFill.Fields("空" & Trim(Str(j))) <> "" Then m = m + 1
                    Next
                    txtdiv(m - 1) = Trim(Str(Val(txtdiv(m - 1)) + 1))
                    sfl = sfl & "," & Trim(Str(.Fields("编号")))
           End Select
          .MoveNext
     Wend
     '显示小题数
     txtsum(4) = Trim(Str(Val(txtdiv(0)) + Val(txtdiv(1)) * 2 + Val(txtdiv(2)) * 3 + Val(txtdiv(3)) * 4))
     txttotalscore = Trim(Str(Val(txtscores(0)) + Val(txtscores(1)) + Val(txtscores(2)) + Val(txtscores(3)) + Val(txtscores(4))))
     '获得试题数据
     vj = Split(sj, ",")
     vso = Split(sso, ",")
     vsm = Split(ssm, ",")
     vfl = Split(sfl, ",")
     vans = Split(sans, ",")
     ReDim ijudge(UBound(vj))
     For i = 0 To UBound(vj)
     ijudge(i) = Val(vj(i))
     Next
     ReDim iselone(UBound(vso))
     For i = 0 To UBound(vso)
     iselone(i) = Val(vso(i))
     Next
     ReDim iselmany(UBound(vsm))
     For i = 0 To UBound(vsm)
     iselmany(i) = Val(vsm(i))
     Next
     ReDim ifill(UBound(vfl))
     For i = 0 To UBound(vfl)
     ifill(i) = Val(vfl(i))
     Next
     ReDim ianswer(UBound(vans))
     For i = 0 To UBound(vans)
     ianswer(i) = Val(vans(i))
     Next
    End If
     .Close
End With
Set objtemp = Nothing
End If
End Sub

Private Sub Cmdauto_Click()
Dim i%, j%, m%, s%, n%, ifl%(4)
'testdiy.lstjudge.Enabled = False
'testdiy.lstselone.Enabled = False
'testdiy.lstselmany.Enabled = False
'testdiy.lstfill.Enabled = False
'testdiy.lstanswer.Enabled = False
'检验试题设置是否正确
If Check_Seting() = False Then Exit Sub
'根据小题数量定义数组大小
ReDim ijudge(Val(txtsum(0)))
ReDim iselone(Val(txtsum(1)))
ReDim iselmany(Val(txtsum(2)))
ReDim ianswer(Val(txtsum(3)))
ReDim ifill(Val(txtsum(4)))
'(1)随机产生判断题
For i = 1 To Val(txtsum(0))
    With objJudge
         n = Int(Rnd * .RecordCount + 1) '随机产生一个记录号
         '获得试题编号
         .MoveFirst
         .Move n - 1, adBookmarkFirst
         n = .Fields("编号")
         '检查试题编号是否重复
         For j = 1 To i - 1
             If ijudge(j) = n Then Exit For
         Next
         If j < i Then
            i = i - 1 '重新抽取题号
         Else
            ijudge(i) = n '保存为重复的题号
         End If
     End With
Next
'(2)随机产生单项选择题
For i = 1 To Val(txtsum(1))
        With objSelOne
          n = Int(Rnd * .RecordCount + 1) '随机产生一个记录号
          '获得试题编号
          .MoveFirst
          .Move n - 1, adBookmarkFirst
          n = .Fields("编号")
          '检查试题编号是否重复
          For j = 1 To i - 1
              If iselone(j) = n Then Exit For
           Next
          If j < i Then
              i = i - 1 '重新抽取题号
          Else
              iselone(i) = n '保存为重复的题号
          End If
       End With
Next
'(3)随机产生多项选择题
For i = 1 To Val(txtsum(2))
       With objselmany
            n = Int(Rnd * .RecordCount + 1) '随机产生一个记录号
            '获得试题编号
            .MoveFirst
            .Move n - 1, adBookmarkFirst
             n = .Fields("编号")
            '检查试题编号是否重复
            For j = 1 To i - 1
              If iselmany(j) = n Then Exit For
            Next
            If j < i Then
                i = i - 1 '重新抽取题号
            Else
                iselmany(i) = n '保存为重复的题号
            End If
        End With
Next
'随机产生问答题
For i = 1 To Val(txtsum(3))
          With objanswer
                n = Int(Rnd * .RecordCount + 1) '随机产生一个记录号
                '获得试题编号
                .MoveFirst
                .Move n - 1, adBookmarkFirst
                 n = .Fields("编号")
                 '检查试题编号是否重复
                For j = 1 To i - 1
                    If ianswer(j) = n Then Exit For
                Next
                If j < i Then
                    i = i - 1 '重新抽取题号
                Else
                    ianswer(i) = n '保存为重复的题号
                End If
          End With
Next
'随机产生填空题
s = 1
For i = 1 To Val(txtsum(4))
         With objFill
               n = Int(Rnd * .RecordCount + 1) '随机产生一个记录号
               '获得试题编号
               .MoveFirst
               .Move n - 1, adBookmarkFirst
               n = .Fields("编号")
               '检查试题编号是否重复
               For j = 1 To i - 1
                   If ifill(j) = n Then Exit For
               Next
               If j < i Then
                    i = i - 1 '重新抽取题号
               Else
                    '计算选中题的填空数
                    m = 0
                    For j = 1 To 4
                    If .Fields("空" & Trim(Str(j))) <> "" Then m = m + 1
                    Next
                    If ifl(m) < Val(txtdiv(m - 1)) Then
                    ifill(s) = n
                    s = s + 1
                    ifl(m) = ifl(m) + 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))
    testdiy.lstselmany.AddItem Trim(Str(iselmany(i)))
Next
For i = 1 To Val(txtsum(3))
    testdiy.lstanswer.AddItem Trim(Str(ianswer(i)))
Next
For i = 1 To Val(txtsum(4))
    If ifill(i) = 0 Then Exit For
    testdiy.lstfill.AddItem Trim(Str(ifill(i)))
Next
Me.Hide
testdiy.Show
Cmdsave.Enabled = True
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 iselmany(Val(txtsum(2)))
ReDim Preserve ianswer(Val(txtsum(3)))
ReDim Preserve ifill(Val(txtsum(4)))
'显示手工选题窗口
For i = 1 To Val(txtsum(0))
If ijudge(i) = 0 Then Exit For
testdiy.lstjudge.AddItem (Str(ijudge(i)))
Next
For i = 1 To Val(txtsum(1))
If iselone(i) = 0 Then Exit For
testdiy.lstselone.AddItem (Str(iselone(i)))
Next
For i = 1 To Val(txtsum(2))
If iselmany(i) = 0 Then Exit For
testdiy.lstselmany.AddItem (Str(iselmany(i)))
Next
For i = 1 To Val(txtsum(3))
If ianswer(i) = 0 Then Exit For
testdiy.lstanswer.AddItem (Str(ianswer(i)))
Next
For i = 1 To Val(txtsum(4))
If ifill(i) = 0 Then Exit For
testdiy.lstfill.AddItem (Str(ifill(i)))
Next
Me.Hide
testdiy.Show
Cmdsave.Enabled = True
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
                MsgBox "创建试题库，保存试题"
                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(iselmany)
       If iselmany(i) = 0 Then Exit For
       strSQL = "insert into  " & Trim(txtname) & _
             "(编号,题型,分数) values(" & Str(iselmany(i)) & ",'多选题'," _
             & txtscore(2) & ")"
      .Execute strSQL
       Next
      For i = 1 To UBound(ifill)
      If ifill(i) = 0 Then Exit For
      strSQL = "insert into  " & Trim(txtname) & _
             "(编号,题型,分数) values(" & Str(ifill(i)) & ",'填空题'," _
             & txtscore(4) & ")"
      .Execute strSQL
      Next
      For i = 1 To UBound(ianswer)
      If ianswer(i) = 0 Then Exit For
      strSQL = "insert into  " & Trim(txtname) & _
             "(编号,题型,分数) values(" & Str(ianswer(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 txtdiv_Change(Index As Integer)
'txtsum(4) = Trim(Str(Val(txtdiv(0)) + Val(txtdiv(1)) * 2 + Val(txtdiv(2)) * 3 + Val(txtdiv(3)) * 4))
'Dim m%, n%, i%
'For Index = 1 To 4
'm = m + Val(txtdiv(Index))
'n = n + Val(txtdiv(Index)) * Index
'Next
'Txtfillsum = m
'txtfillscores = n
'End Sub





'Private Sub txtscores_Change(Index As Integer)
'If Val(txtscores(Index)) <> 0 Then
'txttotalscore = Trim(Str(Val(txtscores(0)) + Val(txtscores(1)) + Val(txtscores(2)) + Val(txtscores(3)) + Val(txtscores(4))))
'End If
'End Sub