form20.frm

主要用于学校机房考试,主要包括选择题,问答题,WORD操作题,WINDOWS操作题.学生做完后,可立即得到考试分数.

List2.Clear
If Node = DBName Then '如果点击的是数据库
db = True '记录
'清除DataGrid里面的内容
If Cnn.State = adStateOpen Then Cnn.Close
'DataGrid1.ClearFields
'DataGrid1.caption = ""
'DataGrid1.Refresh
'deletefields.Enabled = False
Exit Sub
Else
'DeleteFields.Enabled = True
db = False '记录点击的是表
End If
TBName = Node '记录表名
'打开数据库为DataGrid提供数据
strSQL = "SELECT * FROM " & TBName
If Cnn.State = adStateOpen Then Cnn.Close
Cnn.Open "Provider=Microsoft.Jet.OLEDB.3.51; Data Source=" & Text1.Text
'With rst
'    .CursorType = adOpenKeyset
'    .LockType = adLockOptimistic
'    .Open strSQL, Cnn, , , adCmdText
'End With
'Set DataGrid1.DataSource = rst
Data1.DatabaseName = Text1.Text
Data1.RecordSource = strSQL
Data1.Refresh
For i = 0 To Data1.Recordset.Fields.Count - 1 Step 1
List1.AddItem Data1.Recordset.Fields(i).Name
Next
'DataGrid1.caption = Node & "(共" & rst.RecordCount & "条记录)"
'此处不可写Cnn.Close,否则DataGrid就没数据了
End Sub

'该函数用来做圆角窗体
Public Sub RMe()
Dim Regn As Long '定义设置区域的句柄
Dim CER As Long '定义临时句柄变量
'把Twip计量单位转换成象素
X1 = Me.Width / 15
Y1 = Me.Height / 15
'画矩形
Regn = CreateRectRgn(0, 26, X1, Y1 - 26) '把句柄设为第一个矩形区域
CER = CreateRectRgn(23, 0, X1 - 23, Y1) '创建第二个矩形区域
CombineRgn Regn, Regn, CER, RGN_OR '把临时句柄变量或运算到句柄变量中
'由于第四个圆角较小，这里要用矩形补足
CER = CreateRectRgn(23, 52, X1, Y1 - 6)
CombineRgn Regn, Regn, CER, RGN_OR
CER = CreateRectRgn(52, 52, X1 - 6, Y1)
CombineRgn Regn, Regn, CER, RGN_OR
'画四个圆
CER = CreateEllipticRgn(0, 0, 52, 52)
CombineRgn Regn, Regn, CER, RGN_OR
CER = CreateEllipticRgn(X1 - 50, 0, X1 + 1, 52)
CombineRgn Regn, Regn, CER, RGN_OR
CER = CreateEllipticRgn(0, Y1 - 52, 52, Y1)
CombineRgn Regn, Regn, CER, RGN_OR
CER = CreateEllipticRgn(X1 - 9, Y1 - 9, X1, Y1)
CombineRgn Regn, Regn, CER, RGN_OR
Call SetWindowRgn(Me.hwnd, Regn, True) '创建窗体

End Sub





Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Imclose.Tag <> "" Then
Imclose.Picture = LoadPicture()
Imclose.Tag = ""
End If
If Immin.Tag <> "" Then
Immin.Picture = LoadPicture()
Immin.Tag = ""
End If
If Immax.Tag <> "" Then
Immax.Picture = LoadPicture()
Immax.Tag = ""
End If

End Sub

Private Sub Form_Resize()
On Error Resume Next
'改变一些控件位置
IMBar.Width = Me.Width - 1100
Immax.Top = 120
Immax.Left = Me.Width - 780
Immin.Top = 120
Immin.Left = Me.Width - 1095
Imclose.Top = 120
Imclose.Left = Me.Width - 465
Pbottom.Top = Me.Height - Pbottom.Height
Pbottom.Width = Me.Width - 240
Pright.Left = Me.Width - Pright.Width
Pright.Height = Me.Height - 240
Pjiao.Left = Me.Width - Pjiao.Width
Pjiao.Top = Me.Height - Pjiao.Height

'用于把主窗体图片打印成适合窗体大小
Me.Line (0, 0)-(Me.Width, Me.Height), Me.BackColor, BF
Me.PaintPicture Pmain.Picture, 420, 0, Me.Width, 600, 420, 0, 120, 600
Me.PaintPicture Pmain.Picture, 420, Me.Height - 600, Me.Width, 600, 420, Pmain.Height - 600, 120, 600

Me.PaintPicture Pmain.Picture, 0, 0, 200, Me.Height, 0, 880, 200, 40
Me.PaintPicture Pmain.Picture, Me.Width - 200, 0, 200, Me.Height, Pmain.Width - 200, 880, 200, 40

Me.PaintPicture Pmain.Picture, 0, 0, 450, 600, 0, 0, 450, 600
Me.PaintPicture Pmain.Picture, 0, Me.Height - 600, 450, 600, 0, Pmain.Height - 600, 450, 600

Me.PaintPicture Pmain.Picture, Me.Width - 1665, 0, 1665, 435, Pmain.Width - 1665, 0, 1665, 435
Me.PaintPicture Pmain.Picture, Me.Width - 1665, Me.Height - 525, 1665, 525, Pmain.Width - 1665, Pmain.Height - 525, 1665, 525
Me.PaintPicture Imico, 240, 100, 240, 240, 0, 0, 240, 240 '打印标题图标
Me.ForeColor = 12691863
Me.CurrentX = 530
Me.CurrentY = 110
Me.Print Me.caption '打印标题，有阴影的
Me.ForeColor = 11100191
Me.CurrentX = 540
Me.CurrentY = 120
Me.Print Me.caption

RMe

End Sub
Function FileExists(fname$) As Boolean
On Error Resume Next '设置错误处理
Dim X As Integer

X = FreeFile '取得一个空闲文件句柄
Open fname$ For Input As X '试图打开该文件
If Err = 0 Then '如果打开成功
FileExists = False
Else '否则
FileExists = True
End If
Close X
End Function
Private Sub Form_Load()
On Error Resume Next
Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
ROButton2.Enabled = False
ROButton3.Enabled = False
ROButton4.Enabled = False
ROButton5.Enabled = False
ROButton6.Enabled = False
ROButton10.Enabled = False
End Sub

Private Sub IMBar_DblClick()
Immax_Click '双击标题栏时最大化和还原
End Sub

Private Sub IMBar_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'不用多说，拖动窗体
If Button = 1 Then
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If

End Sub

Private Sub ImClose_Click()
Unload Me
End Sub

Private Sub Immax_Click()
'由于最大化和还原按钮是同一个Image，所以这里麻烦一点
If Me.WindowState = 2 Then
Me.WindowState = 0
Pbottom.Visible = True
Pright.Visible = True
Immax.ToolTipText = "最大化"
Else
Me.WindowState = 2
Pbottom.Visible = False
Pright.Visible = False
Me.Line (Immax.Left, Immax.Top)-(Immax.Left + 240, Immax.Top + 240), 16448250, BF
Me.PaintPicture IMus0.Picture, Immax.Left, Immax.Top, 240, 240, 0, 0, 240, 240
Immax.ToolTipText = "还原"
End If
End Sub

Private Sub ImMin_Click()
Me.WindowState = 1
End Sub

Private Sub ImMin_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Immin.Picture = ImMin2.Picture
End Sub
Private Sub ImMin_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Immin.Tag = "" Then
Immin.Picture = ImMin1.Picture
Immin.Tag = "1"
End If
End Sub
Private Sub ImMin_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Immin.Picture = LoadPicture()
Immin.Tag = ""
End Sub


Private Sub Imclose_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Imclose.Picture = ImClose2.Picture
End Sub
Private Sub Imclose_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Imclose.Tag = "" Then
Imclose.Picture = ImClose1.Picture
Imclose.Tag = "1"
End If
End Sub
Private Sub Imclose_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Imclose.Picture = LoadPicture()
Imclose.Tag = ""
End Sub

Private Sub Immax_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Me.WindowState = 0 Then Immax.Picture = Immax2.Picture
If Me.WindowState = 2 Then Immax.Picture = IMus2.Picture
End Sub
Private Sub Immax_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Immax.Tag = "" Then
If Me.WindowState = 0 Then Immax.Picture = Immax1.Picture
If Me.WindowState = 2 Then Immax.Picture = IMus1.Picture
Immax.Tag = "1"
End If
End Sub
Private Sub Immax_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Immax.Picture = LoadPicture()
Immax.Tag = ""
End Sub

Private Sub pbottom_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Pbottom.Tag = ""
End Sub
Private Sub pbottom_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Pbottom.Tag = "1"
End Sub
Private Sub pbottom_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
If Pbottom.Tag <> "" Then
Dim pos As POINTAPI
GetCursorPos pos
gg = pos.Y * 15 - Me.Top
If gg > 1500 Then Me.Height = gg '获得鼠标位置，用来改变窗体大小，这可是一个好办法哟
End If

End Sub

Private Sub Pright_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Pright.Tag = ""
End Sub
Private Sub Pright_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Pright.Tag = "1"
End Sub
Private Sub Pright_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
If Pright.Tag <> "" Then
Dim pos As POINTAPI
GetCursorPos pos
gg = pos.X * 15 - Me.Left
If gg > 2500 Then Me.Width = gg
End If

End Sub


Private Sub Pjiao_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Pjiao.Tag = ""
End Sub
Private Sub Pjiao_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Pjiao.Tag = "1"
End Sub
Private Sub Pjiao_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
If Pjiao.Tag <> "" Then
Dim pos As POINTAPI
GetCursorPos pos
gg = pos.X * 15 - Me.Left
gg2 = pos.Y * 15 - Me.Top
If gg > 2500 Then Me.Width = gg
If gg2 > 1500 Then Me.Height = gg2

End If

End Sub
Private Sub ROButton10_Click()
On Error Resume Next
For i = 0 To List1.ListCount - 1 Step 1
If List1.Selected(i) Then
List2.AddItem List1.Text
List1.RemoveItem (List1.ListIndex)
Exit Sub
End If
Next

End Sub

Private Sub ROButton2_Click()
For i = 0 To List1.ListCount - 1 Step 1
List2.AddItem List1.List(i)
Next
List1.Clear
End Sub

Private Sub ROButton3_Click()
On Error Resume Next
For i = 0 To List2.ListCount - 1 Step 1
If List2.Selected(i) Then
List1.AddItem List2.Text
List2.RemoveItem (List2.ListIndex)
Exit Sub
End If
Next
End Sub

Private Sub ROButton4_Click()
For i = 0 To List2.ListCount - 1 Step 1
List1.AddItem List2.List(i)
Next
List2.Clear
End Sub

Private Sub ROButton5_Click()
'On Error GoTo a1
Dim ListStr As String
Dim fname As String
fname = "c:\" & Trim(Text2.Text) & ".dbf"


If List2.ListCount <> 0 Then
    For i = 0 To List2.ListCount - 1 Step 1
        If (i <> List2.ListCount - 1) Then
           
            ListStr = ListStr + List2.List(i) + ","
        Else
            ListStr = ListStr + List2.List(i)
          
        End If
    Next
End If
            If ListStr = "" Then
               Data1.RecordSource = TBName
               MsgBox "请选择字段", vbOKOnly, "选择字段"
            Else
                If FileExists(fname) Then
                Set dbs = Workspaces(0).OpenDatabase(Text1.Text)
                ROButton5.Enabled = False
                dbs.Execute "SELECT " + ListStr + " INTO [dBase III;DATABASE=c:\].[" & Text2.Text & ".DBF] FROM [" & TBName & "]"
                ROButton5.Enabled = True
                MsgBox "成功导出为vf数据库格式", vbOKOnly, "成功导出"
                Else
                Text2.Text = ""
                MsgBox "文件已存在，请重新输入导出文件名"
                End If
            End If
End Sub

Private Sub ROButton6_Click()
Dim ListStr As String
Dim fname As String
fname = "c:\" & Trim(Text2.Text) & ".xls"
If List2.ListCount <> 0 Then
    For i = 0 To List2.ListCount - 1 Step 1
        If (i <> List2.ListCount - 1) Then
           
            ListStr = ListStr + List2.List(i) + ","
        Else
            ListStr = ListStr + List2.List(i)
          
        End If
    Next
End If
            If ListStr = "" Then
               Data1.RecordSource = TBName
               MsgBox "请选择字段", vbOKOnly, "选择字段"
            Else
                If FileExists(fname) Then
                    Set dbs = Workspaces(0).OpenDatabase(App.Path & "\teacher.mdb")
                    ROButton6.Enabled = False
                    dbs.Execute "SELECT " + ListStr + " INTO [Excel 8.0;DATABASE=c:\" & Text2.Text & ".XLS].[" & TBName & "] FROM [" & TBName & "]"
                    ROButton6.Enabled = True
                      MsgBox "成功导出为excel格式", vbOKOnly, "成功导出"
                    Else
                    Text2.Text = ""
                     MsgBox "文件已存在，请重新输入导出文件名"
                End If
            End If
End Sub