VB运行的时候出现错误,能帮我修改一下吗。我的论文。
Public miCount As IntegerPrivate Sub cmdCancel_Click() ''退出程序
End
End Sub
Private Sub cmdOK_Click() ''进入..确定
'On Error GoTo Err
Dim txtSql As String
UserName = ""
If Trim(txtUserName.Text) = "" Then ''判断用户名是否为空
MsgBox "请输入帐号！", vbOKOnly + vbExclamation, "警告"
txtUserName.SetFocus
Exit Sub
End If
If Trim(txtPassword.Text) = "" Then '判断密码是否为空
MsgBox "请输入密码！", vbOKOnly + vbExclamation, "警告"
txtPassword.SetFocus
Exit Sub
End If
''判断是否有这个用户
txtSql = "select * from 用户信息表 where 用户名称= '" & txtUserName.Text & "'"
If rs.State Then rs.Close
rs.Open txtSql, CN, adOpenStatic, adLockOptimistic
If rs.EOF = True Then ''如果没有这个用户
MsgBox "没有这个帐号，请重新输入帐号!", vbOKOnly + vbExclamation, "警告"
txtUserName.Text = ""
txtPassword.Text = ""
txtUserName.SetFocus
Else ''如果有用户
If Trim(rs.Fields(1)) = Trim(txtPassword.Text) Then
''判断权限
UserPrivs = ""
If Trim(rs.Fields(2)) = "管理员" Then ''管理员权限
IsUserMode = 1
ElseIf Trim(rs.Fields(2)) = "操作员" Then ''普通用户权限
IsUserMode = 2
Else ''无权
IsUserMode = 0
MsgBox "你没有权限!", vbExclamation, "警告"
End
End If
UserPrivs = Trim(rs.Fields(2))
UserName = Trim(txtUserName.Text)
Unload Me
Mainfrm.Show
Exit Sub
Else
MsgBox "输入密码不正确，请重新输入！", vbOKOnly + vbExclamation, "警告"
txtPassword.SetFocus
txtPassword.Text = ""
End If
End If
rs.Close
miCount = miCount + 1
If miCount = 3 Then ''三次错误,自动退出程序
End
End If
Exit Sub
Err:
MsgBox Err.Description & "登录出错,请找管理员!", vbExclamation
Ok = False
End
End Sub
Private Sub Form_Activate()
txtUserName.SetFocus
End Sub
Private Sub Form_Load()
On Error GoTo Err
''连数据库代码
If CN.State Then CN.Close
CN.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\database.mdb;Persist Security Info=False"
CN.Open
miCount = 0
Ok = False
txtUserName.Text = GetSetting(App.Title, "Settings", "user_name", "")
Label2.MouseIcon = cmdOK.MouseIcon
Exit Sub
Err:
MsgBox Err.Description, , "数据库连接错误"
End
End Sub
Private Sub Label1_Click()
Form5.Show 1
End Sub
Private Sub Label2_Click()
End
End Sub
Private Sub txtPassword_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Call cmdOK_Click
End If
End Sub
Private Sub txtUserName_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtPassword.SetFocus
End If
End Sub
主界面图及代码：
Private Sub DatabaseHf_Click()
frmHF.Show 1
End Sub
Private Sub Exit_Click()
End
End Sub
Private Sub FindStudent_Click()
Form2.Show 1
End Sub
Private Sub Findxg_Click()
Form8.Show 1
End Sub
Private Sub Form_Load()
PrivsSeting ''加载权限设置
End Sub
Private Sub Form_Resize()
On Error GoTo Err '''改变控件位置代码
Picture1.Top = 0
Picture1.Left = 0
Picture1.Height = Me.ScaleHeight - StatusBar1.Height
Picture1.Width = Me.ScaleWidth
StatusBar1.Panels(1).Text = "操作员:" & UserName
Label9.Left = (Picture1.ScaleWidth - Label9.Width) / 2
Label9.Top = Picture1.ScaleHeight / 2 - Label9.Height / 2
Label1.Top = Label9.Top + 50
Label1.Left = Label9.Left + 50
''加载背景代码
Image1.Picture = LoadPicture(App.Path & "\1.jpg")
Picture1.Refresh
Picture1.PaintPicture Image1.Picture, Picture1.ScaleTop, Picture1.ScaleLeft, Picture1.ScaleWidth, Picture1.ScaleHeight, 0, 0, Image1.Width, Image1.Height
Err:
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub HelpFiles_Click() '''帮助文件
On Error GoTo Err
Mainfrm.StatusBar1.Panels(2).Text = "帮助文件"
Dim strPath As String
strPath = App.Path + "\系统说明.doc"
ShellExecute hWnd, "open", mFso.GetFileName(strPath), lpParameters, mFso.GetParentFolderName(strPath), 5
Exit Sub
Err:
MsgBox Err.Description
End Sub
Private Sub Infocj_Click()
strTableName = "成绩信息"
Form6.Show 1
End Sub
Private Sub InfoCqjl_Click()
strTableName = "考勤信息"
Form7.Show 1
End Sub
Private Sub InfoJf_Click()
strTableName = "奖罚信息"
Form7.Show 1
End Sub
Private Sub InfoKc_Click()
strTableName = "课程信息"
Form1.Show 1
End Sub
Private Sub InfoKwhd_Click()
strTableName = "课外活动信息"
Form7.Show 1
End Sub
Private Sub infoStudent_Click()
strTableName = "学生基本信息"
Form1.Show 1
End Sub
Private Sub InofBs_Click()
strTableName = "比赛信息"
Form7.Show 1
End Sub
Private Sub Sjbf_Click()
frmDatabase.Show 1
End Sub
Private Sub SysAbout_Click() ''关于
frmAbout.Show 1
End Sub
Private Sub sysManager_Click()
Form3.Show 1
End Sub
Private Sub Userpasword_Click() ''用户密码
Form4.Show 1
End Sub
Public Sub PrivsSeting() '权限设置
If IsUserMode = 1 Then ''管理员
ElseIf IsUserMode = 2 Then
sysManager.Visible = False
Infomanage.Visible = False
End If
End Sub
用户管理代码
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub Command2_Click() ''添加用户
On Error GoTo Err
If Trim(Text8.Text) <> "" And Trim(Text9.Text) <> "" And Trim(Combo1.Text) <> "" Then
Dim rs1 As New ADODB.Recordset
If rs1.State Then rs1.Close
rs1.Open "select count(*) from user_Form where user_Id='" & Trim(Text8.Text) & "'", Cn, adOpenStatic, adLockOptimistic
If rs1.Fields(0) > 0 Then
MsgBox "用户已经存在! 请改user_Id!", , "系统提示"
Text8.Text = ""
Exit Sub
End If
If rs1.State Then rs1.Close
rs1.Open "select * from user_Form", Cn, adOpenStatic, adLockOptimistic
rs1.AddNew
rs1.Fields(0).Value = Trim(Text8.Text)
rs1.Fields(1).Value = Trim(Text9.Text)
rs1.Fields(2).Value = Date
rs1.Fields(3).Value = Trim(Combo1.Text)
rs1.Update
Combo5.AddItem Trim(Text8.Text)
MsgBox "用户添加成功!,初始密码为" & Text9.Text, , "系统提示"
Text8.Text = ""
End If
Exit Sub
Err:
MsgBox Err.Description
End Sub
Private Sub Command3_Click() ''删除用户代码
If Trim(Combo5.Text) = UserName Then
MsgBox "不能删除正在操作的用户!"
Exit Sub
End If
Cn.Execute "delete from user_Form where user_Id='" & Trim(Combo5.Text) & "'"
Combo5.RemoveItem (Combo5.ListIndex)
MsgBox "操作已成功!", , "提示"
End Sub
Private Sub Form_Load() ''初始化代码
On Error GoTo Err
Text8.Text = ""
Dim rs1 As New ADODB.Recordset
rs1.Open "select * from user_Form", Cn, adOpenStatic, adLockOptimistic
Combo5.Clear
While Not rs1.EOF
If Not IsNull(rs1.Fields(0)) Then Combo5.AddItem Trim(rs1.Fields(0))
rs1.MoveNext
Wend
Err:
End Sub
查询界面及源代码
Dim rs2 As New ADODB.Recordset '''记录集,检索用的
Private Sub cmdExcel_Click() ''excel输出
On Error GoTo Err
If MSHFlexGrid1.TextMatrix(0, 0) = "" Then Exit Sub
Dim i As Integer
Dim j As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add '打开已经存在的EXCEL工件簿文件
Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
For i = 0 To MSHFlexGrid1.Rows - 1
For j = 0 To MSHFlexGrid1.Cols - 1
xlSheet.Cells(i + 1, j + 1) = Trim(MSHFlexGrid1.TextMatrix(i, j))
Next j
Next i
xlApp.Visible = True
Exit Sub
Err:
MsgBox Err.Description, , "错误"
xlBook.Close (True) '关闭工作簿
xlApp.Quit '结束EXCEL对象
Set xlApp = Nothing '释放xlApp对象
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdLook_Click() ''查询代码
If Trim(Combo2.Text) <> "" And Trim(Combo3.Text) <> "" And Trim(Combo4.Text) <> "" And Trim(Text1.Text) <> "" Then
Dim strsql As String
strsql = "select * from " & Trim(Combo2.Text) & " where " & Trim(Combo3.Text) & " " & Trim(Combo4.Text) & "'"
If Combo4.Text = "like" Then
strsql = strsql & "%" & Trim(Text1.Text) & "%'"
Else
strsql = strsql & Trim(Text1.Text) & "'"
End If
If rs2.State Then rs2.Close
rs2.Open strsql, CN, adOpenStatic, adLockOptimistic
Set MSHFlexGrid1.DataSource = rs2
Else
MsgBox "请选择或输入数据!", , "系统提示"
End If
End Sub
Private Sub Combo2_Click()
If rs2.State Then rs2.Close
rs2.Open "select * from " & Trim(Combo2.Text), CN, adOpenStatic, adLockOptimistic
Dim i As Integer
Combo3.Clear
For i = 0 To rs2.Fields.Count - 1
Combo3.AddItem rs2.Fields(i).Name
Next i
Combo3.Text = Combo3.List(0)
Set MSHFlexGrid1.DataSource = rs2
End Sub
Private Sub Form_Load()
Me.Caption = "综合检索"
'Combo2.Text = strTableName
Mainfrm.StatusBar1.Panels(2).Text = strTableName & "检索"
End Sub
