Option Explicit

Public msFindField As String '查找的字段
Public msFindOp As String '查找的运算符
Public msFindExpr As String '查找的表达式的值
'表示用户是否取消查询，如果取消查询则为就为True；否则为False
Public mbFindFailed As Boolean

Private Sub cmdCancel_Click()
mbFindFailed = True
Me.Hide
End Sub

Private Sub txtExpression_Change()
cmdOK.Enabled = Len(lstFields.Text) > 0 And Len(lstOperators.Text) > 0 And Len(txtExpression.Text) > 0
End Sub

Private Sub lstFields_Click()
cmdOK.Enabled = Len(lstFields.Text) > 0 And Len(lstOperators.Text) > 0 And Len(txtExpression.Text) > 0
End Sub

Private Sub lstOperators_Click()
cmdOK.Enabled = Len(lstFields.Text) > 0 And Len(lstOperators.Text) > 0 And Len(txtExpression.Text) > 0
End Sub

Private Sub Form_Load()
'加载查询所需要使用的运算符号
lstOperators.AddItem "="
lstOperators.AddItem "<>"
lstOperators.AddItem ">="
lstOperators.AddItem "<="
lstOperators.AddItem ">"
lstOperators.AddItem "<"
lstOperators.AddItem "Like"
lstOperators.ListIndex = 0

mbFindFailed = True
End Sub

Private Sub cmdOK_Click()
mbFindFailed = False

'改变指针，告知读者当前处于忙的状态
Screen.MousePointer = vbHourglass

'取得查询所需要的字段、符号和值
msFindField = lstFields.Text
msFindExpr = txtExpression.Text
msFindOp = lstOperators.Text

Me.Hide

'恢复指针，告知读者系统已经不忙了
Screen.MousePointer = vbDefault
End Sub

Private Sub cmdOK_Click()
'取得用户输入的用户名和密码
Dim user As String, pwd As String
user = txtUser
pwd = txtPwd

'根据不同的身份，选择不同的表用以查询
Dim r As New ADODB.Recordset
Set r = DataEnv.rssqlSeek
Dim strSQL As String
Select Case mnUserType
Case 0: '若身份为管理员
strSQL = "select * from admin where name='" & user & "' and pwd='" & pwd & "'"
Case 1: '若身份为学生
strSQL = "select * from student where name='" & user & "' and serial='" & pwd & "'"
End Select

On Error Resume Next
'查询DataEnv.rssqlSeek的状态，如果已经打开，则先关闭
If r.State = adStateOpen Then r.Close
r.Open strSQL '根据strSQL的内容刷新DataEnv.rssqlSeek

'用户密码错误的次数，如果错误次数超过3次，则退出系统
Static nTryCount As Integer

If r.EOF Then '登录失败
MsgBox "对不起，无此用户或者密码不正确！请重新输入！！", vbCritical, "错误"
txtUser.SetFocus
txtUser.SelStart = 0
txtUser.SelLength = Len(txtUser)
nTryCount = nTryCount + 1
If nTryCount >= 3 Then
MsgBox "您无权操作本系统!再见！", vbCritical, "无权限"
Unload Me
End If
Else '登陆成功
'显示MDI窗体, 并将用户类型和用户名传到MDI窗体中的mnUserType, msUserName中
Load MDIMain
With MDIMain
.mnUserType = mnUserType
.msUserName = pwd
.Show
End With
Unload Me
End If
End Sub

Private Sub Form_Load()
optUserType(0).Value = True
End Sub

Private Sub optUserType_Click(Index As Integer)
mnUserType = Index
End Sub

Option Explicit

'标识是否能关闭
Dim mbClose As Boolean

'标识当前要显示的照片的文件
Dim mstrFileName As String

'当DataEnv.rsStudent的当前记录发生变化时，刷新所绑定的控件(用户改变了当前记录)
Sub RefreshBinding()
On Error Resume Next
With DataEnv.rsStudent
If DataEnv.rssqlSeek.BOF And DataEnv.rssqlSeek.EOF Then
'如果不存在任何记录，则清空所有的绑定的内容
txtSerial = ""
txtName = ""
txtBirthday = ""
txtTelephone = ""
txtAddress = ""
txtResume = ""
imgPhoto.Picture = LoadPicture(Null)
Else '否则和相应的字段进行绑定
txtSerial = .Fields("serial")
txtName = .Fields("name")
txtBirthday = .Fields("birthday")
txtTelephone = .Fields("tel")
txtAddress = .Fields("address")
txtResume = .Fields("resume")
cboSex.Text = .Fields("sex")
dcbClass.Text = .Fields("class")
imgPhoto.Picture = LoadPicture(ReadImage(.Fields("photo")))
End If
End With
End Sub

''在DataEnv.rsStudent中查询serial为sSerial的学籍信息
Sub SeekStudent(sSerial As String)
If Not (DataEnv.rsStudent.EOF And DataEnv.rsStudent.BOF) Then
Dim Temp As String
Temp = "serial = " & "'" & sSerial & "'"

DataEnv.rsStudent.MoveFirst
DataEnv.rsStudent.Find Temp

'刷新所绑定的控件
Call RefreshBinding
End If
End Sub

''当改变记录集时，需要刷新用户导航的网格控件
Sub RefreshGrid()
grdScan.DataMember = ""
grdScan.Refresh
DataEnv.rssqlSeek.Requery
grdScan.DataMember = "sqlSeek"
grdScan.Refresh

'刷新各个绑定控件
Call grdScan_Change
End Sub

''用以在浏览时，根据当前记录所出的位置不同，来改变个浏览按钮的状态
Sub ChangeBrowseState()
With DataEnv.rssqlSeek
If .State = adStateClosed Then .Open
'如果没有任何记录，使某些按钮无效；否则则使这些按钮有效
If .BOF And .EOF Then
cmdAdd.Enabled = True
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdUpdate.Enabled = False
cmdReport.Enabled = False

fraBrowse.Enabled = False
Else
cmdAdd.Enabled = True
cmdEdit.Enabled = True
cmdDelete.Enabled = True
cmdUpdate.Enabled = False
cmdReport.Enabled = True

fraBrowse.Enabled = True
End If

''假如处于记录的头部
If .BOF Then
If Not .EOF Then DataEnv.rsStudent.MoveFirst
cmdPrevious.Enabled = False
cmdFirst.Enabled = False
Else
cmdPrevious.Enabled = True
cmdFirst.Enabled = True
End If
''假如处于记录的尾部
If .EOF Then
If Not .BOF Then DataEnv.rsStudent.MoveLast
cmdNext.Enabled = False
cmdLast.Enabled = False
Else
cmdNext.Enabled = True
cmdLast.Enabled = True
End If
End With

mstrFileName = ""
End Sub

Private Sub cboDep_Click()
Dim rsClass As New ADODB.Recordset
Dim strSQL
'根据所选的系的不同，采用不同的SQL语句
If cboDep.ItemData(cboDep.ListIndex) = 0 Then
strSQL = "select * from class"
Else
strSQL = "select * from class where dept_id=" & cboDep.ItemData(cboDep.ListIndex)
End If

rsClass.Open strSQL, DataEnv.Con

'将所查到的rsClass中的内容来填充cboClass
cboClass.Clear
cboClass.AddItem "全部"
While Not rsClass.EOF
cboClass.AddItem rsClass("Name")
rsClass.MoveNext
Wend
cboClass.ListIndex = 0

rsClass.Close
Set rsClass = Nothing
End Sub

Private Sub cmdAdd_Click()
'添加记录
fraSeek.Enabled = False
fraBrowse.Enabled = False
grdScan.Enabled = False

DataEnv.rsStudent.AddNew
txtBirthday.Text = "1980-01-01"

fraInfo.Enabled = True
fraBrowse.Enabled = False

cmdAdd.Enabled = False
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdUpdate.Enabled = True
cmdReport.Caption = "取消"
cmdReport.Enabled = True

mbClose = False '不能关闭窗口
End Sub

Private Sub cmdDelete_Click()
'如果出错，则显示错误代码
On Error GoTo errHandler

If MsgBox("要删除记录?", vbYesNo + vbQuestion + vbDefaultButton2, "确认") = vbYes Then
'通过在DataEnv.Con中执行SQL命令，来删除记录
DataEnv.Con.Execute "delete from student where serial ='" & txtSerial & "'"

DataEnv.rsStudent.MoveNext
If DataEnv.rsStudent.EOF Then DataEnv.rsStudent.MoveLast
'刷新用户导航的网格控件
Call RefreshGrid
End If

Exit Sub

errHandler:
MsgBox Err.Description, vbCritical, "错误"
End Sub

Private Sub cmdEdit_Click()
'编辑记录之前，需要设置其他控件的Enabled属性
fraSeek.Enabled = False
fraBrowse.Enabled = False
grdScan.Enabled = False

fraInfo.Enabled = True

cmdAdd.Enabled = False
cmdEdit.Enabled = False
cmdDelete.Enabled = False
cmdUpdate.Enabled = True

cmdReport.Caption = "取消" ''更改cmdReport标题
cmdReport.Enabled = True

mbClose = False '出于编辑状态，则用户不能关闭窗口
End Sub

Private Sub cmdFirst_Click()
'移动到记录的头部，并改变各个浏览按钮的状态
DataEnv.rssqlSeek.MoveFirst
DataEnv.rssqlSeek.MovePrevious
Call ChangeBrowseState
End Sub

Private Sub cmdLast_Click()
'移动到记录的尾部，并改变各个浏览按钮的状态
DataEnv.rssqlSeek.MoveLast
DataEnv.rssqlSeek.MoveNext
Call ChangeBrowseState
End Sub

Private Sub cmdList_Click()
'针对所选的班级，列出班级中所有的学籍信息

Dim strSQL
If cboClass.Text = "全部" Then
strSQL = " from student order by serial"
Else
strSQL = " from student where class='" & cboClass & "' order by serial"
End If

DataEnv.rsStudent.Close
DataEnv.rsStudent.Open "select * " & strSQL

DataEnv.rssqlSeek.Close
DataEnv.rssqlSeek.Open "select serial, name " & strSQL


'刷新用户导航的网格控件，并且根据记录集中记录的数目，来改变各个浏览按钮的状态。
Call RefreshGrid
Call ChangeBrowseState

Call grdScan_Change
End Sub

Private Sub cmdNext_Click() '移动到记录的下一条
DataEnv.rssqlSeek.MoveNext
Call ChangeBrowseState
End Sub

Private Sub cmdPrevious_Click() '移动到记录的上一条
DataEnv.rssqlSeek.MovePrevious
Call ChangeBrowseState
End Sub

Private Sub cmdReport_Click()
On Error Resume Next
If cmdReport.Caption = "取消" Then
'取消所使用的更新更新
DataEnv.rsStudent.CancelUpdate

'重新显示原来数据集中的内容
If DataEnv.rsStudent.BOF Then
DataEnv.rsStudent.MoveFirst
Else
DataEnv.rsStudent.MovePrevious
DataEnv.rsStudent.MoveNext
End If
Call RefreshBinding
Call ChangeBrowseState

fraSeek.Enabled = True
fraBrowse.Enabled = True
fraInfo.Enabled = False
grdScan.Enabled = True
cmdReport.Caption = "报表(R)"

mbClose = True
Else
'生成报表
Dim strSQL As String
DataEnv.rsrptStudent.Close
strSQL = "select * from student where serial = '" & txtSerial.Text & "'"
DataEnv.rsrptStudent.Open strSQL

rptStudent.Show
End If
End Sub

Private Sub cmdSeek_Click()
With frmFind
Dim i As Integer
'显示查找窗口
Load frmFind

'填充查找窗体的字段列表框
.lstFields.Clear
For i = 0 To DataEnv.rsStudent.Fields.Count - 1
.lstFields.AddItem (DataEnv.rsStudent(i).Name)
Next i
.lstFields.ListIndex = 0
.Show 1

If .mbFindFailed Then Exit Sub

Dim sTemp As String
If LCase(.msFindOp) = "like" Then
sTemp = .msFindField & " " & .msFindOp & " '%" & .msFindExpr & "%'"
Else
sTemp = .msFindField & " " & .msFindOp & " '" & .msFindExpr & "'"
End If
sTemp = "select * from student where " & sTemp & " order by serial"

Unload frmFind
End With

'查找数据，并刷新用以导航的网格控件
DataEnv.rssqlSeek.Close
DataEnv.rssqlSeek.Open sTemp
Call RefreshGrid

Exit Sub

errHandler:
MsgBox "没有符合条件的纪录！", vbExclamation, "确认"
End Sub

Private Sub cmdSelectPhoto_Click()
On Error GoTo errHandler:

dlgSelect.DialogTitle = "选择该学生的照片"
dlgSelect.Filter = "所有图形文件|*.bmp;*.dib;*.gif;*.jpg;*.ico|位图文件(*.bmp;*.dib)|*.bmp;*.dib|GIF文件(*.gif)|*.gif|JPEG文件(*.jpg)|*.jpg|图标文件(*.ico)|*.ico"

dlgSelect.ShowOpen

If dlgSelect.FileName = "" Then Exit Sub

imgPhoto.Picture = LoadPicture(dlgSelect.FileName)
mstrFileName = dlgSelect.FileName

Exit Sub

errHandler:
MsgBox Err.Description, vbCritical, "错误"
End Sub

Private Sub cmdUpdate_Click()
'更新所添加或者修改的记录
On Error GoTo errHandler:

Dim str As String
str = txtSerial.Text

With DataEnv.rsStudent
.Fields("Serial") = txtSerial.Text
.Fields("name") = txtName.Text
.Fields("sex") = cboSex.Text
.Fields("class") = dcbClass.Text
.Fields("birthday") = txtBirthday.Text
.Fields("tel") = txtTelephone.Text
.Fields("address") = txtAddress.Text
.Fields("resume") = txtResume.Text

Call WriteImage(.Fields("photo"), mstrFileName)
.Update
End With

cmdReport.Caption = "报表(&R)"
cmdUpdate.Enabled = False
fraInfo.Enabled = False
mbClose = True

If DataEnv.rssqlSeek.State = adStateClosed Then DataEnv.rssqlSeek.Open
'刷新右端用以导航的网格控件
Call RefreshGrid
'根据记录集中记录的个数，改变各个按钮的状态
Call ChangeBrowseState

'定位到刚刚添加或者修改过的记录
DataEnv.rssqlSeek.MoveFirst
DataEnv.rssqlSeek.Find "serial='" & str & "'"

fraSeek.Enabled = True
fraBrowse.Enabled = True
grdScan.Enabled = True
Exit Sub

errHandler:
MsgBox Err.Description, vbCritical, " 错误"
End Sub

Private Sub dcbClass_Click(Area As Integer)
If txtSerial = "" Then
txtSerial = dcbClass.Text
End If
End Sub

Private Sub Form_Load()
On Error Resume Next

Dim rsDep As New ADODB.Recordset, rsClass As New ADODB.Recordset
Set rsDep = DataEnv.rsDepartment
Set rsClass = DataEnv.rsClass

'从Department表中读取数据，填充cboDep复合框到中
rsDep.Open
cboDep.Clear
cboDep.AddItem "全部"
'将各个系的id号作为ItemData附加到复合框中
cboDep.ItemData(0) = 0
While Not rsDep.EOF
cboDep.AddItem rsDep("Name")
cboDep.ItemData(cboDep.ListCount - 1) = rsDep("id")
rsDep.MoveNext
Wend
cboDep.ListIndex = 0

''从class表中读取数据，填充到cboClass复合框中
cboClass.Clear
cboClass.AddItem "全部"
While Not rsClass.EOF
cboClass.AddItem rsClass("Name")
rsClass.MoveNext
Wend
cboClass.ListIndex = 0

cmdList.Value = True

fraManage.Enabled = True
fraBrowse.Enabled = True
fraSeek.Enabled = True
grdScan.Enabled = True

mbClose = True

Call grdScan_Change
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not mbClose Then
MsgBox "数据正被修改，窗口不能关闭", vbCritical, "错误"
Cancel = True
End If
End Sub

Private Sub grdScan_Change()
If grdScan.ApproxCount > 0 Then
Call SeekStudent(grdScan.Columns(0).CellText(grdScan.Bookmark))
End If
End Sub

Private Sub grdScan_RowColChange(LastRow As Variant, ByVal LastCol As Integer)
'当前行改变，则动态改变所要显示的记录
If LastRow <> grdScan.Bookmark Then
If grdScan.ApproxCount > 0 Then
Call SeekStudent(grdScan.Columns(0).CellText(grdScan.Bookmark))
End If
End If
End Sub

Private Sub WriteImage(ByRef Fld As ADODB.Field, DiskFile As String)
Dim byteData() As Byte '定义数据块数组
Dim NumBlocks As Long '定义数据块个数
Dim FileLength As Long '标识文件长度
Dim LeftOver As Long '定义剩余字节长度
Dim SourceFile As Long '定义自由文件号
Dim i As Long '定义循环变量

Const BLOCKSIZE = 4096 '每次读写块的大小

SourceFile = FreeFile '提供一个尚未使用的文件号
Open DiskFile For Binary Access Read As SourceFile '打开文件
FileLength = LOF(SourceFile) '得到文件长度
If FileLength = 0 Then '判断文件是否存在
Close SourceFile
MsgBox DiskFile & "无 内 容 或 不 存 在 !"
Else
NumBlocks = FileLength \ BLOCKSIZE '得到数据块的个数
LeftOver = FileLength Mod BLOCKSIZE '得到剩余字节数
Fld.Value = Null
ReDim byteData(BLOCKSIZE) '重新定义数据块的大小
For i = 1 To NumBlocks
Get SourceFile, , byteData() ' 读到内存块中
Fld.AppendChunk byteData() '写入FLD
Next i

ReDim byteData(LeftOver) '重新定义数据块的大小
Get SourceFile, , byteData() '读到内存块中
Fld.AppendChunk byteData() '写入FLD
Close SourceFile '关闭源文件
End If
End Sub

Private Function ReadImage(blobColumn As ADODB.Field) As String
'取得一个临时性文件
Dim strFileName As String
strFileName = "ImageTmp"

Dim FileNumber As Integer '文件号
Dim DataLen As Long '文件长度
Dim Chunks As Long '数据块数
Dim ChunkAry() As Byte '数据块数组
Dim ChunkSize As Long '数据块大小
Dim Fragment As Long '零碎数据大小
Dim lngI As Long '计数器

On Error GoTo errHander

ChunkSize = 2048 '定义块大小为 2K
If IsNull(blobColumn) Then Exit Function

DataLen = blobColumn.ActualSize '获得图像大小
If DataLen < 8 Then Exit Function '图像大小小于8字节时认为不是图像信息
FileNumber = FreeFile '产生随机的文件号
Open strFileName For Binary Access Write As FileNumber '打开存放图像数据文件
Chunks = DataLen \ ChunkSize '数据块数
Fragment = DataLen Mod ChunkSize '零碎数据
If Fragment > 0 Then '有零碎数据，则先读该数据
ReDim ChunkAry(Fragment - 1)
ChunkAry = blobColumn.GetChunk(Fragment)
Put FileNumber, , ChunkAry '写入文件
End If

ReDim ChunkAry(ChunkSize - 1) '为数据块重新开辟空间
For lngI = 1 To Chunks '循环读出所有块
ChunkAry = blobColumn.GetChunk(ChunkSize) '在数据库中连续读数据块
Put FileNumber, , ChunkAry() '将数据块写入文件中
Next lngI
Close FileNumber '关闭文件

ReadImage = strFileName

Exit Function

errHander:
ReadImage = ""
End Function

Option Explicit

Private Sub cmdClose_Click()
Unload Me
End Sub

Private Sub Form_Load()
'根据当前登录的用户在DataEnv.rsStudent中查找到对应的记录
DataEnv.rsStudent.Find "serial = '" & MDIMain.msUserName & "'"
End Sub

Private Sub imgPhoto_Click()

End Sub

Option Explicit

'表示当前的用户类型
'0---管理员类型的用户; 1---学生类型的用户
Public mnUserType As Integer
'表示当前登录的用户名
Public msUserName As String

Private Sub MDIForm_Activate()
'根据不同的用户类型，使相应的菜单项可见
Select Case mnUserType
Case 0: '以管理员身份登录
mnuFind.Visible = True
Case 1: '以学生身份登录， 只能查询自己的信息
mnuFind.Visible = False
End Select
End Sub

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If MsgBox("真的要对出本系统吗？", vbQuestion + vbYesNo + vbDefaultButton2, "退出") = vbNo Then
Cancel = 1
End If
End Sub

Private Sub mnuAbout_Click()
'显示“关于...”窗口
Load frmSplash
frmSplash.mbAbout = True
frmSplash.Show vbModal
End Sub

Private Sub mnuExit_Click()
Unload Me
End Sub

Private Sub mnuFind_Click()
frmStudent.Show
frmStudent.cmdSeek.Value = True
End Sub

Private Sub mnuLogin_Click()
If MsgBox("若重新登录，所有窗体都将关闭！是否重新登录？", _
vbQuestion + vbYesNo + vbDefaultButton2, "重新登录") = vbYes Then
Unload MDIMain
frmLogin.Show
End If
End Sub

Private Sub mnuStudent_Click()
If mnUserType = 0 Then '若为管理员用户
frmStudent.Show
Else '若为学生类用户
frmView.Show
End If
End Sub

这个一个建一个窗口