frmstsc.frm

一个题库系统 可以按照试题的难度

        CreateTXS_ONE tmp_item.Text, tmp_item.SubItems(1), SJ_ND, SJ_LX, SJ_ID
    Next
       
End Sub
'创建一种题型的试题
Private Function CreateTXS_ONE(ByVal st_lx As String, _
        ByVal FS As Long, _
        ByVal SJ_ND As String, ByVal SJ_LX As String, _
        ByVal SJ_ID As String) As Boolean
    Dim sSQL As String
    Dim rs_stbl As New ADODB.Recordset
    Dim st_fs As Long
    
    sSQL = "select * from sjdy where sjnd='" & SJ_ND & "'"
    rs_stbl.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
    
    If rs_stbl.EOF And rs_stbl.BOF Then GoTo lab
    
    Do While Not rs_stbl.EOF
        st_fs = rs_stbl("BL") * FS / 100
        CreateRndSt SJ_LX, st_lx, rs_stbl("stnd"), st_fs, SJ_ID
        rs_stbl.MoveNext
    Loop
    CreateTXS_ONE = True
    rs_stbl.Close
    Exit Function
lab:
    MsgMsg "请先定义试卷的难度级别" & SJ_ND
    CreateTXS_ONE = False
End Function
'创建一种题型的某一种难度的试题
Private Sub CreateRndSt(ByVal SJ_LX As String, _
        ByVal st_lx As String, _
        ByVal st_nd As String, _
        ByVal st_zf As Long, ByVal SJ_ID As String)
    
    Dim sSQL As String
    Dim rs_st As New ADODB.Recordset
    Dim rs_sjst As New ADODB.Recordset
    
    sSQL = "select * from STK where lx='" & SJ_LX & "' and " & _
           " tx='" & st_lx & "' and nd='" & st_nd & "'"
    rs_st.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
    If rs_st.EOF And rs_st.BOF Then Exit Sub
    
    Dim current_fs As Long
    Dim rnd_pos As Long
    Dim upperbound As Long
    Dim i_count As Long
    Dim sjst_id As String
    
    i_count = 0
    current_fs = 0
    
      
    Randomize 1
    upperbound = rs_st.RecordCount - 1
    Do While current_fs < st_zf
        rnd_pos = Int((upperbound + 1) * Rnd(1))
        rs_st.Move rnd_pos, adBookmarkFirst
        
        If (rs_st("XZ") = "-1") Then
            'ADD
            sjst_id = GetID
            sSQL = "select * from sj_stk where id='" & sjst_id & "'"
            rs_sjst.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
            rs_sjst.AddNew
            rs_sjst("id") = sjst_id
            rs_sjst("tx") = rs_st("tx")
            rs_sjst("fz") = rs_st("fz")
            rs_sjst("nd") = rs_st("nd")
            rs_sjst("nz") = rs_st("nz")
            rs_sjst("da") = rs_st("da")
            rs_sjst("sjid") = SJ_ID
            rs_sjst.Update
            rs_sjst.Close
            current_fs = current_fs + rs_st("fz")
            rs_st("xz") = 1
        Else
            i_count = 0
            Do While 1
                rs_st.MoveNext
                If rs_st.EOF Then rs_st.MoveFirst
                If i_count > rs_st.RecordCount Then
                    'GoTo lab
                    rs_st.Close
                    Exit Sub
                End If
                If (rs_st("XZ") = "-1") Then
                'ADD
                    sjst_id = GetID
                    sSQL = "select * from sj_stk where id='" & sjst_id & "'"
                    rs_sjst.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
                    rs_sjst.AddNew
                    rs_sjst("id") = sjst_id
                    rs_sjst("tx") = rs_st("tx")
                    rs_sjst("fz") = rs_st("fz")
                    rs_sjst("nd") = rs_st("nd")
                    rs_sjst("nz") = rs_st("nz")
                    rs_sjst("da") = rs_st("da")
                    rs_sjst("sjid") = SJ_ID
                    rs_sjst.Update
                    rs_sjst.Close
                    current_fs = current_fs + rs_st("fz")
                    rs_st("xz") = 1
                    Exit Do
                End If
                i_count = i_count + 1
            Loop
        End If
    Loop
    rs_st.Cancel
    rs_st.CancelUpdate
    rs_st.Close

End Sub


Private Sub Command4_Click()
    
    If Text2.Text = "" Then
        MsgMsg "试卷名称不能为空!"
        Exit Sub
    End If
    If Text1.Text = "" Then
        MsgMsg "试卷套数不能为空!"
        Exit Sub
    End If
    If Text5.Text = "" Then
        MsgMsg "零分试卷方案不能存储!"
        Exit Sub
    End If
    If List1.ListItems.Count <= 0 Then
        MsgMsg "没有确定试题不能保存!"
        Exit Sub
    End If
    
    
    Dim sSQL As String
    Dim Rs As New ADODB.Recordset
    
    sSQL = "select * from scfa where id='" & m_ID & "'"
    Rs.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
    Select Case m_Type
    Case SNEW
        Rs.AddNew
        Rs("ID") = m_ID
    Case SEDIT
        Rs("ID") = m_ID
    End Select
    
    Rs("sjmc") = Text2.Text
    Rs("kslx") = Combo3.Text
    Rs("sjnd") = Combo1.Text
    Rs("scfs") = CInt(Text1.Text)
    Rs("bz") = Text4.Text
    Rs.Update
    Rs.Close
    
    Dim tmp_item As ListItem
    sSQL = "delete from scfa_txfz where scfa_id='" & m_ID & "'"
    dbcon.Execute sSQL
    sSQL = "select * from scfa_txfz where scfa_id='" & m_ID & "'"
    Rs.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
    For Each tmp_item In List1.ListItems
        Rs.AddNew
        Rs("scfa_id") = m_ID
        Rs("tx") = tmp_item.Text
        Rs("fz") = CInt(tmp_item.SubItems(1))
        Rs.Update
    Next
    Rs.Close
    
    m_Type = SEDIT
    MsgMsg "保存完毕!"
    
    
    
End Sub

Private Sub Command5_Click()
    Unload Me
End Sub

Private Sub Command6_Click()
    If MsgboxYesOrNo("是否真的要出除?") Then
        dbcon.Execute "delete from scfa where id='" & m_ID & "'"
        dbcon.Execute "delete from scfa_txfz where scfa_id='" & m_ID & "'"
        Unload Me
    End If
End Sub

Private Sub Command7_Click()
    SetNew
End Sub

Private Sub Command8_Click()
    ShowForm frjSJCK, SNEW, m_ID
End Sub

Private Sub Form_Load()
    On Error Resume Next
    Dim Rs As New ADODB.Recordset
    Dim sql As String
    
    
    sql = "select * from setings where type='SETING'"
    Rs.Open sql, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
    If (Rs.EOF And Rs.BOF) Or IsNull(Rs("xml_value")) Then
        MsgMsg "请先完成系统设置!"
        Exit Sub
    End If
    xml_txt = Rs("xml_value")
    Rs.Close
    SetNumMask Text1
    SetNumMask Text3
    SetCombo Combo3, xml_txt, "专业"
    SetCombo Combo2, xml_txt, "题型"
    SetCombo Combo1, xml_txt, "试卷"
    
    List1.View = lvwReport
    List1.ColumnHeaders.Add , , "题型", (List1.Width - 20) / 2
    List1.ColumnHeaders.Add , , "分值", (List1.Width - 20) / 2

    
    Select Case m_Type
    Case SNEW
        SetNew
    Case SEDIT
        GetData
    End Select
    
End Sub

Private Sub Form_Resize()
    SetWindowPos Me
End Sub
Private Sub SetNew()
    On Error Resume Next
    
    Text2.Text = ""
    Combo3.ListIndex = 0
    Combo1.ListIndex = 0
    Text1.Text = ""
    Text4.Text = ""
    Combo2.ListIndex = 0
    Text3.Text = ""
    List1.ListItems.Clear
    Text5.Text = "0"
    
    m_Type = SNEW
    m_ID = GetID
End Sub
Private Sub SetCombo(ByRef co_obj As ComboBox, ByVal xml_str As String, ByVal xm1 As String)
    On Error Resume Next
    Dim xml_doc As New MSXML.DOMDocument
    Dim list_nodes As IXMLDOMNodeList
    Dim node As IXMLDOMElement
    Dim local_uil As String
    
    xml_doc.loadXML xml_str
    
    
    local_uil = "项目/" & xm1 & "/ITEM"
    Set list_nodes = xml_doc.getElementsByTagName(local_uil)
    
    co_obj.Clear
    For Each node In list_nodes
        co_obj.AddItem node.Text
    Next
    co_obj.ListIndex = 0
    
End Sub
Private Sub GetData()
    On Error Resume Next
    Dim sSQL As String
    Dim Rs As New ADODB.Recordset
    
    sSQL = "select * from scfa where id='" & m_ID & "'"
    Rs.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
        
    Text2.Text = Rs("sjmc")
    Combo3.Text = Rs("kslx")
    Combo1.Text = Rs("sjnd")
    Text1.Text = Rs("scfs")
    Text4.Text = Rs("bz")
    Rs.Close
    
    Dim tmp_item As ListItem
    Dim l_tmp As Long
    l_tmp = 0
    sSQL = "select * from scfa_txfz where scfa_id='" & m_ID & "'"
    Rs.Open sSQL, dbcon, adOpenKeyset, adLockOptimistic, adCmdText
    Do While Not Rs.EOF
        Set tmp_item = List1.ListItems.Add(, , Rs("tx"))
        tmp_item.SubItems(1) = Rs("fz")
        l_tmp = l_tmp + Rs("fz")
        Rs.MoveNext
    Loop
    Rs.Close
    Text5.Text = l_tmp
    
End Sub
Private Sub AddTxfz()
    If Text3.Text = "" Then
        MsgMsg "请填写题型分值!"
        Exit Sub
    End If
    
    Dim tmp_item As ListItem
    
    For Each tmp_item In List1.ListItems
        If Combo2.Text = tmp_item.Text Then
            MsgMsg "已经加入该题型!"
            Exit Sub
        End If
    Next
    
    Set tmp_item = List1.ListItems.Add(, , Combo2.Text)
    tmp_item.SubItems(1) = Text3.Text
    
    Dim l_tmp As Long
    l_tmp = 0
    For Each tmp_item In List1.ListItems
        l_tmp = l_tmp + CInt(tmp_item.SubItems(1))
    Next
    Text5.Text = l_tmp
End Sub

Private Sub List1_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 46 Then Call DeleteTxfz
End Sub

Private Sub Text3_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Call Command1_Click
    End If
End Sub
Private Sub DeleteTxfz()
    On Error Resume Next
    If List1.ListItems.Count = 0 Then Exit Sub
    Text5.Text = CInt(Text5.Text) - (List1.SelectedItem.SubItems(1))
    List1.ListItems.Remove List1.SelectedItem.Index
End Sub