frmpanduan.frm

自己用vb开发的局域网考试系统

               Charset         =   134
               Weight          =   700
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            ForeColor       =   &H000000C0&
            Height          =   240
            Left            =   4800
            TabIndex        =   12
            Top             =   285
            Width           =   1290
         End
         Begin VB.Label Label7 
            AutoSize        =   -1  'True
            Caption         =   "难度："
            BeginProperty Font 
               Name            =   "宋体"
               Size            =   10.5
               Charset         =   134
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   210
            Left            =   6630
            TabIndex        =   11
            Top             =   300
            Width           =   540
         End
      End
   End
   Begin MSComctlLib.ImageList ImgLst 
      Left            =   0
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   95
      ImageHeight     =   24
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   4
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "FrmPanDuan.frx":0270
            Key             =   "save"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "FrmPanDuan.frx":0301
            Key             =   "undo"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "FrmPanDuan.frx":0370
            Key             =   "new"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "FrmPanDuan.frx":03EE
            Key             =   "edit"
         EndProperty
      EndProperty
   End
End
Attribute VB_Name = "FrmPanDuan"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim NewOrEdit As String

'检查试卷库里是否已经用了该题目
Function CheckTestId(ByVal Qid As Long, ByVal IdString) As Boolean
  CheckTestId = True
  Dim i As Integer
  Dim IDArr() As String
  If IdString <> "" Then
    IDArr = Split(IdString, ",")
    For i = 0 To UBound(IDArr)
      If Qid = Val(IDArr(i)) Then Exit Function
    Next i
  End If
  CheckTestId = False
End Function
'从LstTM里取得ID号,返回为long型
Function GetID(ByVal IdString) As Long
   GetID = Val(Mid(IdString, 2))
   
End Function

Private Sub CmbND_Click()
    Dim adoRs As Recordset
   Set adoRs = New Recordset
   '查询题目id
   If CmbND.ListIndex <> 0 Then
     adoRs.Open "select id from questionPD where kemuid=" & UseKeMuID & " and nianjiid=" & UseNianJiID & " and nandu='" & CmbND.Text & "'", adoCn, adOpenStatic, adLockOptimistic
    Else
     adoRs.Open "select id from questionPD where kemuid=" & UseKeMuID & " and nianjiid=" & UseNianJiID, adoCn, adOpenStatic, adLockOptimistic
   End If
   LstTM.Clear
  '添加列表
  Do While Not adoRs.EOF
    LstTM.AddItem "第" & adoRs.Fields("id").Value & "题"
    adoRs.MoveNext
  Loop
  Set adoRs = Nothing
  '设置对应的难度选择项
  SetText CmbND.Text, CmbNanDu

End Sub

Private Sub CmdDel_Click()

If LstTM.ListIndex < 0 Then
 MsgBox "你还没有选择要删除的题目呢!", vbExclamation, "系统提示"
 Exit Sub
End If
'========================若此题已被使用则不能删除*****《待做》

Dim adoRs As Recordset
Set adoRs = New Recordset
adoRs.Open "select panduan from test where kemuid=" & UseKeMuID & " and nianjiid=" & UseNianJiID, adoCn, adOpenStatic, adLockOptimistic

Dim TiID As Long
'获得ID号
TiID = GetID(LstTM.List(LstTM.ListIndex))

Do While Not adoRs.EOF
  'MsgBox adoRs.Fields("danxuan")
 ' MsgBox CmdDel.Tag
  If CheckTestId(TiID, adoRs.Fields("panduan")) Then
    MsgBox "试卷库里以使用此题目，现在不能删除！"
    Set adoRs = Nothing
    Exit Sub
  End If
  adoRs.MoveNext
Loop
 Set adoRs = Nothing
 
Dim Result As String
Result = MsgBox("你确实要删除此题目吗!此为无返回过程", vbYesNo + vbExclamation, "提问?")
If Result = vbNo Then Exit Sub
 
'从数据库中删除题目

Dim sql1 As String
sql1 = "delete from questionPD where id=" & TiID
adoCn.Execute sql1
'从LISTVIEW删除题目
LstTM.RemoveItem LstTM.ListIndex

'清除控件内容
ClsTM

End Sub
'判断输入是否合格
Function CheckIn() As Boolean
  CheckIn = False
  If RtbTK.Text = "" Then
    MsgBox "请输入填空题的问题主体！"
    RtbTK.SetFocus
    Exit Function
  End If
  CheckIn = True
End Function
Private Sub CmdEdit_Click()
  Dim TiID As Long
 If CmdNew.ToolTipText = "添加题目" Then
  If LstTM.ListIndex < 0 And NewOrEdit <> "New" Then
   MsgBox "请选择要修改的题目!"
   Exit Sub
  End If
  '========================若此题已被使用则不能修改

  Dim adoRs As Recordset
  Set adoRs = New Recordset
  adoRs.Open "select panduan from test where kemuid=" & UseKeMuID & " and nianjiid=" & UseNianJiID, adoCn, adOpenStatic, adLockOptimistic
  '获得ID号
  TiID = GetID(LstTM.List(LstTM.ListIndex))
  Do While Not adoRs.EOF
    If CheckTestId(TiID, adoRs.Fields("panduan")) Then
      MsgBox "试卷库里以使用此题目，现在不能修改！"
      Exit Sub
    End If
    adoRs.MoveNext
  Loop
  Set adoRs = Nothing
  
  SetEnabled True
  CmdNew.Picture = ImgLst.ListImages(1).Picture
  CmdEdit.Picture = ImgLst.ListImages(2).Picture
  CmdNew.ToolTipText = "保存题目"
  CmdEdit.ToolTipText = "取消保存"
  NewOrEdit = "Edit"
 Else
   If LstTM.ListIndex < 0 Then GoTo NoUndo
  '返回到原状态
   Dim adoTMRs As Recordset
   Dim sql As String
   Set adoTMRs = New Recordset
   '获得ID号
   TiID = GetID(LstTM.List(LstTM.ListIndex))
   sql = "select * from questionPD where id=" & TiID
   adoTMRs.Open sql, adoCn, adOpenStatic, adLockOptimistic
   '清除控件
   ClsTM
   PlayTM adoTMRs
   adoTMRs.Close
NoUndo:
  SetEnabled False
  CmdNew.Picture = ImgLst.ListImages(3).Picture
  CmdEdit.Picture = ImgLst.ListImages(4).Picture
  CmdNew.ToolTipText = "添加题目"
  CmdEdit.ToolTipText = "编辑题目"
  NewOrEdit = ""
 End If
 
End Sub
'清空题目
Sub ClsTM()
 RtbTK.Text = ""

End Sub

Private Sub CmdExit_Click()
 Unload Me
End Sub

Private Sub CmdNew_Click()
  If CmdNew.ToolTipText = "添加题目" Then
  SetEnabled True
  CmdNew.Picture = ImgLst.ListImages(1).Picture
  CmdEdit.Picture = ImgLst.ListImages(2).Picture
  CmdNew.ToolTipText = "保存题目"
  CmdEdit.ToolTipText = "取消保存"
  NewOrEdit = "New"
  If CheQK.Value = 1 Then
    '清空
    ClsTM
  End If
 Else
  
    '判断输入是否合格
    If CheckIn = False Then
       Exit Sub
    End If
    Dim sql As String
    Dim NanDuStr As String, DaanStr As String
    NanDuStr = CmbNanDu.Text
    '得到答案字符串
    If OptDui.Value = True Then
      DaanStr = "T"
     Else
      DaanStr = "F"
    End If
    '判断是添加还是编辑
    If NewOrEdit = "New" Then
      Dim Qid As Long '题目Id
      Qid = GetAutoID("questionPD")
      sql = "insert into questionPD(id,kemuid,nianjiid,wenti,daan,nandu) values ("
      sql = sql & Qid & "," & UseKeMuID & "," & UseNianJiID & ",'" & RtbTK.Text & "','" & DaanStr & "','" & NanDuStr & "')"
      adoCn.Execute sql
      LstTM.AddItem "第" & Qid & "题"
     Else
      '更新
      '用CmdNew控件的Tag属性保存题目ID
      sql = "update questionPD set wenti='" & RtbTK.Text & "',daan='" & DaanStr & "',nandu='" & NanDuStr & "' where id=" & GetID(LstTM.List(LstTM.ListIndex))
      adoCn.Execute sql
    End If
  
  SetEnabled False
  CmdNew.Picture = ImgLst.ListImages(3).Picture
  CmdEdit.Picture = ImgLst.ListImages(4).Picture
  CmdNew.ToolTipText = "添加题目"
  CmdEdit.ToolTipText = "编辑题目"
  NewOrEdit = ""
 End If

'adoQuestionRs.Close

End Sub


Private Sub Form_Load()
  CmbND.ListIndex = 0
  CmbNanDu.ListIndex = 0
  Dim adoRs As Recordset
  Set adoRs = New Recordset
  adoRs.Open "select id from questionPD where kemuid=" & UseKeMuID & " and nianjiid=" & UseNianJiID, adoCn, adOpenStatic, adLockOptimistic
  LstTM.Clear
  Do While Not adoRs.EOF
    LstTM.AddItem "第" & adoRs.Fields("id").Value & "题"
    adoRs.MoveNext
  Loop
  Set adoRs = Nothing
End Sub
'设置是否可以编辑
Sub SetEnabled(ByVal TF As Boolean)
  CmbNanDu.Enabled = TF
  RtbTK.Locked = Not TF
  CmdDel.Enabled = Not TF
  Frame5.Enabled = TF
  Frame2.Enabled = Not TF
End Sub

Private Sub LstTM_Click()
 Dim adoRs As Recordset
 Set adoRs = New Recordset
 adoRs.Open "select * from questionPD where id=" & GetID(LstTM.List(LstTM.ListIndex)), adoCn, adOpenStatic, adLockOptimistic
 PlayTM adoRs
 Set adoRs = Nothing
End Sub

'显示题目
Sub PlayTM(ByVal adoRs As Recordset)
  SetText adoRs.Fields("nandu").Value, CmbNanDu
  RtbTK.Text = adoRs.Fields("wenti").Value
  If adoRs.Fields("daan").Value = "T" Then
     OptDui.Value = True
    Else
     OptCuo.Value = True
  End If
End Sub
'显示下来列表的列
Sub SetText(ByVal TXT As String, ByVal CmbBox As ComboBox)
  Dim i As Integer
  For i = 0 To CmbBox.ListCount - 1
    If CmbBox.List(i) = TXT Then
      CmbBox.ListIndex = i
      Exit Sub
    End If
  Next i
End Sub

Private Sub RtbTK_KeyPress(KeyAscii As Integer)
    If KeyAscii = 39 Then KeyAscii = -24145

End Sub