frmgeneratetestz.frm

这是我们公司的题库管理系统

VERSION 5.00
Begin VB.Form frmTestGenerateZ 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "智能组卷向导"
   ClientHeight    =   3195
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   6030
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3195
   ScaleWidth      =   6030
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.ListBox listTestType 
      Height          =   1860
      Left            =   1200
      TabIndex        =   1
      Top             =   960
      Width           =   3135
   End
   Begin VB.TextBox txtTestName 
      Height          =   375
      Left            =   1200
      TabIndex        =   0
      Top             =   240
      Width           =   3135
   End
   Begin VB.CommandButton CancelButton 
      Caption         =   "取消"
      Height          =   375
      Left            =   4680
      TabIndex        =   4
      Top             =   600
      Width           =   1215
   End
   Begin VB.CommandButton OKButton 
      Caption         =   "确定"
      Height          =   375
      Left            =   4680
      TabIndex        =   2
      Top             =   120
      Width           =   1215
   End
   Begin VB.Label lTestType 
      AutoSize        =   -1  'True
      Caption         =   "组卷类型"
      Height          =   180
      Left            =   240
      TabIndex        =   5
      Top             =   960
      Width           =   720
   End
   Begin VB.Label lTestName 
      AutoSize        =   -1  'True
      Caption         =   "试卷名称"
      Height          =   180
      Left            =   240
      TabIndex        =   3
      Top             =   360
      Width           =   720
   End
End
Attribute VB_Name = "frmTestGenerateZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Dim rsTest, rsItem As adodb.Recordset


Private Sub CancelButton_Click()
    Unload Me
End Sub

Private Sub Form_Load()

    Dim i As Integer
    ' 打开连接
    Set cnn = New Connection
    cnn.Open sConnect


    If categoryId = 1 Then
        ' 使用提供的集合创建 recordset
        Set rs = New Recordset
        rs.CursorLocation = adUseClient
        
        sSQL = "select * from TEST_MODEL where MODEL_TYPE = 'ZhiNeng' Order by MODEL_NAME"
        rs.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
        lTestType.Visible = True
        listTestType.Visible = True
        For i = 1 To rs.RecordCount
            listTestType.AddItem rs!MODEL_NAME
            rs.MoveNext
        Next i
        Me.Caption = "公共试卷组卷向导"
        
        rs.Close
    ElseIf categoryId = 2 Then
        ' 使用提供的集合创建 recordset
        Set rs = New Recordset
        rs.CursorLocation = adUseClient
        
        sSQL = "select * from CATEGORIES where SUPER_CATEGORY_ID = 2"
        rs.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
        lTestType.Visible = True
        listTestType.Visible = True
        For i = 1 To rs.RecordCount
            listTestType.AddItem rs!Name
            rs.MoveNext
        Next i
        Me.Caption = "专业试卷组卷向导"
        
        rs.Close
    ElseIf categoryId = 3 Then
        ' 使用提供的集合创建 recordset
        Set rs = New Recordset
        rs.CursorLocation = adUseClient
        
        lTestType.Visible = False
        listTestType.Visible = False
        Me.Caption = "面试试卷组卷向导"
    End If
    
End Sub

Private Sub Form_Terminate()
On Error Resume Next
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    If Not cnn Is Nothing Then
        cnn.Close
        Set cnn = Nothing
    End If
End Sub

Private Sub OKButton_Click()
    Dim testType As String
    Dim testId As Integer
    If txtTestName.Text <> "" Then
        If listTestType.Text <> "" Then
            If categoryId = 1 Then
                testType = listTestType.Text
                testId = addNewTest(testType)
                Call gTestZ(testId, testType)
            ElseIf categoryId = 2 Then
                testType = "060-100-zhuanye"
                testId = addNewTest(testType)
                Call gTestZhuanYe(testId, testType)
            End If
        Else
            If categoryId = 3 Then
                testType = "040-100-mianshi"
                testId = addNewTest(testType)
                Call gTestMianshi(testId, testType)
            Else
                MsgBox "请选择试卷类型！", vbInformation + vbOKOnly
            End If
        End If
    Else
        MsgBox "请为所组试卷命名！", vbInformation + vbOKOnly
    End If
End Sub

Private Sub gTestMianshi(ByVal testId As Integer, ByVal testType As String)
    Dim i, j, k As Integer
    Dim itemCounts, poolCounts As Integer
    Dim itemCategoryId As String
    Dim categoryType, categorySQL, returnSQL As String
    Dim itemIndex(40) As Integer
    
    sSQL = "select * from TEST_MODEL_ITEM where MODEL_NAME = '" & testType & "'"
    Set rsTest = New Recordset
    rsTest.CursorLocation = adUseClient
    rsTest.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
    
    For i = 1 To rsTest.RecordCount
        itemCounts = rsTest!ITEM_COUNTS
        itemCategoryId = rsTest!ITEM_CATEGORY_ID
        
        sSQL = "select ITEM_ID from ITEM where CATEGORY_ID = " & itemCategoryId & " and VERIFY_STATUS = '已审'"
        rs.CursorLocation = adUseClient
        rs.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
        poolCounts = rs.RecordCount
        If poolCounts < itemCounts Then
            MsgBox "题库中没有足够的备用试题，组卷失败！", vbInformation + vbOKOnly
            cnn.Execute "delete * from TEST_ITEM where TEST_ID = " & testId
            cnn.Execute "delete * from TEST where TEST_ID = " & testId
            GoTo doClose
        Else
            For j = 1 To itemCounts
                Randomize   ' 对随机数生成器做初始化的动作。
                itemIndex(j) = Int((poolCounts * Rnd) + 1)   '生成随机序列号
                ' check if the new index is same as any other indexes
                If j > 1 Then
                    For k = 1 To j - 1
                        If itemIndex(j) = itemIndex(k) Then
                            j = j - 1
                            GoTo doNext
                        End If
                    Next k
                End If
                rs.Move itemIndex(j) - 1, 1        ' move to the paticular record
                cnn.Execute " INSERT INTO TEST_ITEM " _
                    & "(TEST_ID, ITEM_ID, SCORE) VALUES " _
                    & "( '" & testId & "', '" & rs!ITEM_ID & "', " & rsTest!SCORE_PER_ITEM & ");"
doNext:
            Next j
        End If
        rsTest.MoveNext
        rs.Close
    Next i
    
    MsgBox "恭喜，组卷成功！新生成试卷“" & txtTestName.Text & "”。", vbInformation + vbOKOnly

doClose:
    Unload Me
    
End Sub


Private Sub gTestZhuanYe(ByVal testId As Integer, ByVal testType As String)
    Dim i, j, k As Integer
    Dim itemCounts, poolCounts As Integer
    Dim itemTypeId As String
    Dim categoryType, categorySQL, returnSQL As String
    Dim itemIndex(40) As Integer
    
    sSQL = "select * from TEST_MODEL_ITEM where MODEL_NAME = '" & testType & "'"
    Set rsTest = New Recordset
    rsTest.CursorLocation = adUseClient
    rsTest.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
    
    For i = 1 To rsTest.RecordCount
        itemCounts = rsTest!ITEM_COUNTS
        itemTypeId = rsTest!ITEM_TYPE_ID
        
        categorySQL = "select * from CATEGORIES where SUPER_CATEGORY_ID = " _
                & "(select min(CATEGORY_ID) from CATEGORIES where NAME = '" & listTestType.Text & "')"
        categoryType = "SUPER_CATEGORY_ID = "
        returnSQL = getCategorySQL(categoryType, categorySQL)
        categorySQL = "select * from CATEGORIES where " & returnSQL
        categoryType = "CATEGORY_ID = "
        returnSQL = getCategorySQL(categoryType, categorySQL)
        sSQL = "select ITEM_ID from ITEM where (" & returnSQL & ") and TYPE_ID = '" & itemTypeId & "' and VERIFY_STATUS = '已审'"
        rs.CursorLocation = adUseClient
        rs.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
        poolCounts = rs.RecordCount
        If poolCounts < itemCounts Then
            MsgBox "题库中没有足够的备用试题，组卷失败！", vbInformation + vbOKOnly
            cnn.Execute "delete * from TEST_ITEM where TEST_ID = " & testId
            cnn.Execute "delete * from TEST where TEST_ID = " & testId
            GoTo doClose
        Else
            For j = 1 To itemCounts
                Randomize   ' 对随机数生成器做初始化的动作。
                itemIndex(j) = Int((poolCounts * Rnd) + 1)   '生成随机序列号
                ' check if the new index is same as any other indexes
                If j > 1 Then
                    For k = 1 To j - 1
                        If itemIndex(j) = itemIndex(k) Then
                            j = j - 1
                            GoTo doNext
                        End If
                    Next k
                End If
                rs.Move itemIndex(j) - 1, 1        ' move to the paticular record
                cnn.Execute " INSERT INTO TEST_ITEM " _
                    & "(TEST_ID, ITEM_ID, SCORE) VALUES " _
                    & "( '" & testId & "', '" & rs!ITEM_ID & "', " & rsTest!SCORE_PER_ITEM & ");"
doNext:
            Next j
        End If
        rsTest.MoveNext
        rs.Close
    Next i
    
    MsgBox "恭喜，组卷成功！新生成试卷“" & txtTestName.Text & "”。", vbInformation + vbOKOnly

doClose:
    Unload Me
    
End Sub

Private Function addNewTest(ByVal testType As String) As Integer
    Dim testMaxMark, testDuration As Integer
    
    testMaxMark = CInt(Mid(testType, 5, 3))
    testDuration = CInt(Mid(testType, 1, 3))
    cnn.Execute " INSERT INTO TEST" _
         & "(CATEGORY_ID, NAME, MAXMARK, DURATION, status) VALUES " _
         & "( " & categoryId & ", '" _
         & txtTestName.Text & "', " _
         & testMaxMark & ", " _
         & testDuration & "," _
         & "'待审');"
    rs.CursorLocation = adUseClient
    rs.Open "TEST", cnn, adOpenForwardOnly, adLockReadOnly
    rs.MoveLast
    addNewTest = rs!TEST_ID
    rs.Close
End Function

Private Sub gTestZ(ByVal testId As Integer, ByVal testType As String)
    Dim i, j, k As Integer
    Dim itemCounts, poolCounts As Integer
    Dim itemTypeId As String
    Dim categoryType, categorySQL, returnSQL As String
    Dim itemIndex(20) As Integer
    
    sSQL = "select * from TEST_MODEL_ITEM where MODEL_NAME = '" & testType & "'"
    Set rsTest = New Recordset
    rsTest.CursorLocation = adUseClient
    rsTest.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
    
    For i = 1 To rsTest.RecordCount
        itemCounts = rsTest!ITEM_COUNTS
        itemTypeId = rsTest!ITEM_TYPE_ID
        
        categorySQL = "select * from CATEGORIES where SUPER_CATEGORY_ID = " & rsTest!ITEM_CATEGORY_ID
        categoryType = "SUPER_CATEGORY_ID = "
        returnSQL = getCategorySQL(categoryType, categorySQL)
        categorySQL = "select * from CATEGORIES where " & returnSQL
        categoryType = "CATEGORY_ID = "
        returnSQL = getCategorySQL(categoryType, categorySQL)
        sSQL = "select ITEM_ID from ITEM where (" & returnSQL & ") and TYPE_ID = '" & itemTypeId & "' and VERIFY_STATUS = '已审'"
        rs.CursorLocation = adUseClient
        rs.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
        poolCounts = rs.RecordCount
        If poolCounts < itemCounts Then
            MsgBox "题库中没有足够的备用试题，组卷失败！", vbInformation + vbOKOnly
            cnn.Execute "delete * from TEST_ITEM where TEST_ID = " & testId
            cnn.Execute "delete * from TEST where TEST_ID = " & testId
            GoTo doClose
        Else
            For j = 1 To itemCounts
                Randomize   ' 对随机数生成器做初始化的动作。
                itemIndex(j) = Int((poolCounts * Rnd) + 1)   '生成随机序列号
                ' check if the new index is same as any other indexes
                If j > 1 Then
                    For k = 1 To j - 1
                        If itemIndex(j) = itemIndex(k) Then
                            j = j - 1
                            GoTo doNext
                        End If
                    Next k
                End If
                rs.Move itemIndex(j) - 1, 1        ' move to the paticular record
                cnn.Execute " INSERT INTO TEST_ITEM " _
                    & "(TEST_ID, ITEM_ID, SCORE) VALUES " _
                    & "( '" & testId & "', '" & rs!ITEM_ID & "', " & rsTest!SCORE_PER_ITEM & ");"
doNext:
            Next j
        End If
        rsTest.MoveNext
        rs.Close
    Next i
    
    MsgBox "恭喜，组卷成功！新生成试卷“" & txtTestName.Text & "”。", vbInformation + vbOKOnly

doClose:
    Unload Me
    
End Sub

Private Function getCategorySQL(ByVal categoryType As String, ByVal categorySQL As String) As String
    Dim cSQL As String
    Dim i As Integer
    sSQL = categorySQL
    rs.CursorLocation = adUseClient
    rs.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly
    cSQL = categoryType & rs!CATEGORY_ID
    For i = 2 To rs.RecordCount
        rs.MoveNext
        cSQL = cSQL & " or " & categoryType & rs!CATEGORY_ID
    Next i
    rs.Close
    getCategorySQL = cSQL
End Function