frmmanager.frm

学员考试管理系统,采用VISUAL BASIC数据库编程技术,可用于课程设计,毕业设计等.

         Caption         =   "添加题目类别(&L)..."
      End
      Begin VB.Menu mnuTmlbEdit 
         Caption         =   "修改题目类别(&E)..."
      End
      Begin VB.Menu mnuTmlbDel 
         Caption         =   "删除题目类别(&D)..."
      End
      Begin VB.Menu mnu1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuTmAdd 
         Caption         =   "添加题目(&I)..."
         Shortcut        =   ^{INSERT}
      End
      Begin VB.Menu mnuTmEdit 
         Caption         =   "修改题目(&M)..."
      End
      Begin VB.Menu mnuTmDel 
         Caption         =   "删除题目(&R)..."
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpContext 
         Caption         =   "帮助主题(&C)"
         Shortcut        =   {F1}
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于(&A)"
      End
   End
End
Attribute VB_Name = "frmManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const minSplitLimit = 1000 '最小
Private Const minTreeTableWidth = 2000 '
Private sglSplitLimit As Double
Private mrsTK As ADODB.Recordset '题库
Private msTitle As String
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As Long, ByVal lpDirectory As Long, ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL = 1
'重新生成原始题库
Private Sub Command1_Click()
    Dim i As Long
    Dim szSQL As String
    
    On Error GoTo ErrHandler
    Screen.MousePointer = 11
    '从tb?_?中生成题库
    gadoCONN.Execute "DELETE FROM tbTk"
    For i = 1 To 11
        '倒入选择题(0)
        szSQL = "INSERT INTO tbTk(tmlb_id,tmlx_id,tmbh,tmmc,tmda,A,B,C,D,E,F) " & _
              "SELECT " & CStr(i) & ",0,tmbh,tmmc,tmda,A,B,C,D,E,F FROM tb" & CStr(i) & "_0"
        gadoCONN.Execute szSQL
        
        '倒入判断题(1)
        szSQL = "INSERT INTO tbTk(tmlb_id,tmlx_id,tmbh,tmmc,tmda) " & _
              "SELECT " & CStr(i) & ",1,tmbh,tmmc,tmda FROM tb" & CStr(i) & "_1"
        gadoCONN.Execute szSQL
    Next i
    Screen.MousePointer = 0
    MsgBox "重新生成题库操作成功！", vbOKOnly + vbInformation, Me.Caption
    Exit Sub
ErrHandler:
    Screen.MousePointer = 0
    ErrMessageBox Me.Name & "_重新生成题库Command1_Click()", Me.Caption
End Sub
'倒入图片
Private Sub Command2_Click()
    Dim idx As Long
    Dim ct As Long
    Dim tmlb As Long
    Dim tmlx As Long
    Dim tmbh As Long
    Dim szSQL As String
    
    Screen.MousePointer = 11
    
    On Error GoTo ErrHandler
    '------------------------------------------
    File1.Pattern = "*.bmp;*.jpg"
    File1.Path = GetAppPath() & "pic"
    
    ct = File1.ListCount
    For idx = 0 To ct - 1
        '获取题目类别、题目类型、题目编号
        GetTmParameters File1.List(idx), tmlb, tmlx, tmbh
        
        '
        szSQL = "UPDATE tbTk SET tp='" & "pic\" & File1.List(idx) & "' WHERE tmlb_id=" & CStr(tmlb) & " AND tmlx_id=" & CStr(tmlx) & " AND tmbh=" & CStr(tmbh)
        gadoCONN.Execute szSQL
    Next idx
    Screen.MousePointer = 0
    MsgBox "图片例入成功！", vbOKOnly + vbInformation, Me.Caption
    Exit Sub
ErrHandler:
    Screen.MousePointer = 0
    ErrMessageBox Me.Name & "_倒入图片Command2_Click()", Me.Caption
End Sub

Private Sub DataGrid1_DblClick()
    Call mnuTmEdit_Click
End Sub

Private Sub Form_Load()
    Dim theArea As RECT
    
    On Error GoTo ErrHandler
    '
    imgBackground.Visible = True
    DataGrid1.Visible = False
    'get the workarea
    theArea = GetWorkArea()
    '设置应用程序的主窗口的大小
    Me.Left = theArea.Left * Screen.TwipsPerPixelX
    Me.Top = theArea.Top * Screen.TwipsPerPixelX
    Me.Width = (theArea.Right - theArea.Left) * Screen.TwipsPerPixelX
    Me.Height = (theArea.Bottom - theArea.Top) * Screen.TwipsPerPixelY
    sglSplitLimit = SSTabWks.Left + SSTabWks.Width
    '强制重画一下各个控件
    SizeControls imgSplitter.Left
    '初始化题库树
    Call InitTreeView
    '---------------------------------------------------------------
    Me.Caption = msTitle
    StatusBar1.Panels(1).Text = "欢迎使用" & Me.Caption
    '获取上次的系统设置
    Call SetViewSettings
    '----------------------------------------------------------------
    Set mrsTK = Nothing
    Exit Sub
ErrHandler:
    Set mrsTK = Nothing
    ErrMessageBox Me.Name & ":Form_Load()", Me.Caption
End Sub
Private Sub SizeControls(ByVal x As Single)
    On Error Resume Next
    '------------------------------------------
    Call SeperateStatusBar(Me.ScaleWidth)
    'set the width
    imgSplitter.Left = x
    SSTabWks.Width = imgSplitter.Left - 2 * SSTabWks.Left
    imgBackground.Left = imgSplitter.Left + imgSplitter.Width
    imgBackground.Width = Me.ScaleWidth - imgBackground.Left - Me.ScaleLeft '(SSTabWks.Width + SSTabWks.Left + )
    
    'set the top and height
    If Toolbar1.Visible Then
        cmdClose.Top = Toolbar1.Height + 60
        SSTabWks.Top = cmdClose.Top + cmdClose.Height + 40
        imgBackground.Top = Toolbar1.Height
        imgBackground.Height = Me.ScaleHeight - Toolbar1.Height - StatusBar1.Height
    Else
        cmdClose.Top = 140
        SSTabWks.Top = cmdClose.Top + cmdClose.Height + 40
        imgBackground.Top = 0
        imgBackground.Height = Me.ScaleHeight - StatusBar1.Height
    End If
    cmdUp.Top = cmdClose.Top
    imgSplitter.Top = imgBackground.Top
    'set the height
    SSTabWks.Height = Me.ScaleHeight + Me.ScaleLeft - SSTabWks.Top - StatusBar1.Height
    imgSplitter.Height = imgBackground.Height
    'set the lines
    lnLeft.x1 = imgSplitter.Left
    lnLeft.X2 = imgSplitter.Left
    lnLeft.y1 = imgSplitter.Top
    lnLeft.Y2 = lnLeft.y1 + imgSplitter.Height
    
    'set command buttons
    cmdClose.Left = SSTabWks.Left + SSTabWks.Width - cmdClose.Width
    cmdUp.Left = cmdClose.Left - cmdUp.Width - 60
    'set the treeview1
    TreeView1.Height = SSTabWks.Height - TreeView1.Top - SSTabWks.TabHeight - 50
    TreeView1.Width = SSTabWks.Width - 90 '2 * lstPoints.Left
    'set the lines
    lnFirWhite.x1 = SSTabWks.Left
    lnFirWhite.X2 = cmdUp.Left - 80
    lnFirWhite.y1 = cmdUp.Top + 50
    lnFirWhite.Y2 = lnFirWhite.y1
    
    lnFirBlack.x1 = lnFirWhite.x1
    lnFirBlack.X2 = lnFirWhite.X2
    lnFirBlack.y1 = lnFirWhite.y1 + 20
    lnFirBlack.Y2 = lnFirBlack.y1
    
    lnSecWhite.x1 = lnFirWhite.x1
    lnSecWhite.X2 = lnFirWhite.X2
    lnSecWhite.y1 = lnFirBlack.y1 + 40
    lnSecWhite.Y2 = lnSecWhite.y1
    
    lnSecBlack.x1 = lnSecWhite.x1
    lnSecBlack.X2 = lnFirWhite.X2
    lnSecBlack.y1 = lnSecWhite.y1 + 20
    lnSecBlack.Y2 = lnSecBlack.y1
    
    Line1.x1 = 0
    Line1.X2 = imgBackground.Left
    Line1.y1 = imgBackground.Top '+ 15
    Line1.Y2 = Line1.y1
    
    Line2.x1 = Line1.x1
    Line2.X2 = Line1.X2
    Line2.y1 = Line1.y1 + 15
    Line2.Y2 = Line2.y1
    
    '-------------------------------------------------------------
    DataGrid1.Left = imgBackground.Left
    DataGrid1.Top = imgBackground.Top
    DataGrid1.Width = imgBackground.Width
    DataGrid1.Height = imgBackground.Height
    
    '画背景
    Call GetBackgroundSettings
End Sub

Private Sub Form_Resize()
    'resize the controls
    SizeControls imgSplitter.Left
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim i As Integer
    
    If MsgBox("真的要退出" & Me.Caption & "吗？", vbYesNo + vbInformation, "提示") = vbNo Then
        Cancel = True
        Exit Sub
    End If
    
    '保存本次的系统设置
    Call SaveViewSettings
    '关闭题库记录集
    If Not mrsTK Is Nothing Then
        If mrsTK.State = adStateOpen Then
            mrsTK.Close
        End If
        Set mrsTK = Nothing
    End If
    
    '断开数据库连接
    If Not gadoCONN Is Nothing Then
        If gadoCONN.State = adStateOpen Then
            gadoCONN.Close
        End If
        Set gadoCONN = Nothing
    End If
    
    'close all sub forms
    For i = Forms.Count - 1 To 1 Step -1
        Unload Forms(i)
    Next
    
    '----------------------------------------
    End
End Sub
Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    On Error Resume Next
    
    With imgSplitter
        picSplitter.Move .Left, .Top, .Width, .Height
    End With
    picSplitter.Visible = True
End Sub

Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    On Error Resume Next
    
    Dim sglPos As Single

    If (Button And vbLeftButton) > 0 Then
        sglPos = x + imgSplitter.Left
        If sglPos >= 0 Then
            picSplitter.Left = sglPos
        Else
            picSplitter.Left = 0
        End If
    End If
End Sub

Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    On Error Resume Next
    
    If picSplitter.Left < sglSplitLimit Then
        picSplitter.Left = sglSplitLimit
    Else
        If picSplitter.Left > (Me.ScaleWidth - sglSplitLimit) Then
            picSplitter.Left = Me.ScaleWidth - sglSplitLimit
        End If
    End If
    SizeControls picSplitter.Left
    picSplitter.Visible = False
End Sub
'设置状态栏
Private Sub SeperateStatusBar(ByVal totalwd As Double)
    Dim wd As Double
    wd = totalwd / 12
    StatusBar1.Panels(1).Width = 4 * wd
    StatusBar1.Panels(2).Width = 4 * wd
    StatusBar1.Panels(3).Width = 2 * wd
    StatusBar1.Panels(4).Width = 2 * wd
End Sub
'将题目类别添加到树形控件上去
Private Sub InitTreeView()
    Dim rs As ADODB.Recordset
    Dim szSQL As String
    Dim i As Long
    Dim ct As Long
    Dim nodeX As Node
    
    On Error GoTo ErrHandler
    szSQL = "SELECT id,name,ctbl FROM tbTmlb ORDER BY id ASC"
    Set rs = gadoCONN.Execute(szSQL)
    If Not rs.EOF Then rs.MoveLast
    If Not rs.BOF Then rs.MoveFirst
    
    '添加树根
    Set nodeX = TreeView1.Nodes.Add(, , "r", "题库", 1, 1)
    nodeX.Expanded = True
    
    ct = rs.RecordCount
    For i = 1 To ct
        Call AddTmlbNode(ToInteger(rs("id")), "" & rs("name"))
        
        rs.MoveNext
    Next i
    Set rs = Nothing
    Exit Sub
ErrHandler:
    Set rs = Nothing
    ErrMessageBox "题库树初始化InitTreeView()", "提示"
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Sub mnuGenTestPaper_Click()
    Call GenTestPaper
End Sub

Private Sub mnuHelp_Click()
    mnuHelpAbout.Caption = "关于 " & Me.Caption & "(&A)..."
End Sub

Private Sub mnuHelpAbout_Click()
    Dim frm As New frmAbout
    
    Load frm
    frm.Show vbModal
End Sub

Private Sub mnuHelpContext_Click()
    ShellExecute Me.hwnd, "Open", GetAppPath() & "jttest.chm", 0, 0, SW_SHOWNORMAL
End Sub

Private Sub mnuOptions_Click()
    Dim frm As frmOptions
    
    Set frm = New frmOptions
    
    frm.SourcePicture = imgBackground
    
    Load frm
    frm.Show vbModal
End Sub

Private Sub mnuShowLargeIcon_Click()
    mnuShowLargeIcon.Checked = Not mnuShowLargeIcon.Checked
    
    ShowLargeIcon mnuShowLargeIcon.Checked
End Sub