vb仓库管理源代码（每日任务管理系统）
vb仓库管理源代码（每日任务管理系统）MsgBox "账号不能为空！"ElseDim 密码text As String '定义变量存储密码If Trim(Me.Text账号) <> "" Then '输入账号不能为空账号text = Me.Text账号 '存储录入账号到变量中（可拓展更多判断，如字符长度等）
前端程序前端程序开发平台为VB6.0，编程语言为Visual Basic
窗体系统登录
Private Sub Command登录_Click()
Dim 账号text As String '定义变量存储账号
Dim 密码text As String '定义变量存储密码
If Trim(Me.Text账号) <> "" Then '输入账号不能为空
账号text = Me.Text账号 '存储录入账号到变量中（可拓展更多判断，如字符长度等）
Else
MsgBox "账号不能为空！"
Exit Sub
End If
If Trim(Me.Text密码) <> "" Then '输入密码不能为空
If Len(Trim(Me.Text密码)) < 6 Then
MsgBox "密码长度不能小于6位！"
Exit Sub
End If
密码text = Me.Text密码 '存储录入密码到变量中（可拓展更多判断，如字符长度等）
Else
MsgBox "密码不能为空！"
Exit Sub
End If
'-账号密码验证
Dim login_conn As New ADODB.Connection '连接到ACCESS数据库
With login_conn 'mdb格式连接
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
Dim login_rs As New ADODB.Recordset
Dim login_sql As String
login_sql = "select * from 账号表 where 账号= '" & Me.Text账号 & "' and 密码='" & Me.Text密码 & "'" '查询用户表
login_rs.Open login_sql login_conn adOpenDynamic adLockOptimistic
If login_rs.EOF = False Then '循环表的内容
'--
On Error Resume Next
login_name = login_rs.Fields("账号").Value '账号密码赋值到公共变量之后使用
login_pw = login_rs.Fields("密码").Value
user_name = login_rs.Fields("姓名").Value
user_role = login_rs.Fields("角色").Value
全部任务权限 = login_rs.Fields("全部任务").Value
任务查看权限 = login_rs.Fields("任务查看").Value
任务添加权限 = login_rs.Fields("任务添加").Value
任务更新权限 = login_rs.Fields("任务更新").Value
任务删除权限 = login_rs.Fields("任务删除").Value
常见任务管理权限 = login_rs.Fields("常见任务管理").Value
负责人管理权限 = login_rs.Fields("负责人管理").Value
任务类型管理权限 = login_rs.Fields("任务类型管理").Value
任务状态管理权限 = login_rs.Fields("任务状态管理").Value
MsgBox "登录成功" "提示"
Unload Me '关闭登录窗体
frm系统主页.Show
Else
MsgBox "账号或密码错误，请重新登录"
login_count = login_count 1 '登录错误3次，退出
If login_count = 3 Then
MsgBox "账号或密码错误达3次"
Unload Me
End If
End If
login_rs.Close
Set login_rs = Nothing
login_conn.Close
Set login_conn = Nothing
Exit Sub
登录失败错误:
MsgBox Err.Description
End Sub
Private Sub Command退出_Click()
Unload Me
End Sub
Private Sub Command用户注册_Click()
frm用户注册.Show 1
End Sub
系统主页
Private Sub cjrw_Click(Index As Integer)
If 常见任务管理权限 = False Then
MsgBox "无权限"
Exit Sub
End If
frm常见任务.Show 1
End Sub
Private Sub fhdl_Click()
Unload Me
frm系统登录.Show
login_name = ""
login_pw = ""
user_name = ""
user_role = ""
全部任务权限 = False
任务查看权限 = False
任务添加权限 = False
任务更新权限 = False
任务删除权限 = False
常见任务管理权限 = False
负责人管理权限 = False
任务类型管理权限 = False
任务状态管理权限 = False
End Sub
Private Sub Form_Load()
StatusBar1.Panels(2).Text = login_name
StatusBar1.Panels(3).Text = user_name
StatusBar1.Panels(4).Text = user_role
Label日期.Caption = Date
'当前登录用户添加的任务
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;Persist Security Info=False"
Adodc1.CommandType = adCmdUnknown
Adodc1.RecordSource = "Select * From 今日任务查询 where " & "创建账号 ='" & login_name & "'"
Adodc1.Refresh '刷新
End Sub
Private Sub fzr_Click(Index As Integer)
If 负责人管理权限 = False Then
MsgBox "无权限"
Exit Sub
End If
frm负责人.Show 1
End Sub
Private Sub grxx_Click()
frm个人信息.Show 1
End Sub
Private Sub qbrw_Click(Index As Integer)
If 全部任务权限 = False Then
MsgBox "无权限"
Exit Sub
End If
frm全部任务.Show 1
End Sub
Private Sub rwcx_Click(Index As Integer)
If 任务查看权限 = False Then
MsgBox "无权限"
Exit Sub
End If
frm任务查询.Show 1
End Sub
Private Sub rwlx_Click(Index As Integer)
If 任务类型管理权限 = False Then
MsgBox "无权限"
Exit Sub
End If
frm任务类型.Show 1
End Sub
Private Sub rwtj_Click(Index As Integer)
If 任务添加权限 = False Then
MsgBox "无权限"
Exit Sub
End If
frm任务添加.Show 1
End Sub
Private Sub rwzt_Click(Index As Integer)
If 任务状态管理权限 = False Then
MsgBox "无权限"
Exit Sub
End If
frm任务状态.Show 1
End Sub
Private Sub tcxt_Click()
Unload Me
End Sub
Private Sub xgmm_Click()
frm修改密码.Show 1
End Sub
常见任务
Option Explicit
Public frm_title As String '存储窗体标题
Public frm_datatype As Integer '存储当前管理状态（添加，修改，查询）
Public key_data As String '存储修改主键
Dim search_filter As String '存储筛选条件
Dim search_order As String '存储排序条件
Private Sub Command保存_Click()
On Error GoTo 保存失败错误
'========================================================================为添加状态时
If frm_datatype = 1 Then
'判断数据不能为空
If Text1(0).Text <> "" Then
'满足条件添加记录
'----------------------------------
Dim add_conn As New ADODB.Connection '连接数据
Dim add_rs As New AdoDB.Recordset
With add_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
add_rs.Open "常见任务表" add_conn adOpenKeyset adLockOptimistic '连接表生成记录集
add_rs.AddNew '添加记录
On Error Resume Next
add_rs!任务名称 = Text1(0).Text '新记录赋值
add_rs.Update '更新
add_rs.Close '关闭清空记录集和连接
Set add_rs = Nothing
add_conn.Close
Set add_conn = Nothing
MsgBox "添加完成"
Text1(0).Text = ""
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Text1(0).SetFocus '第一个录入数据控件获得焦点继续录入
'----------------------------------
Else
MsgBox "任务名称不能为空"
Exit Sub
End If
End If
'========================================================================为修改状态时
If frm_datatype = 2 Then
'判断数据不能为空
If Text1(0).Text <> "" Then
'判断主键不能重复
If key_data <> Text1(0).Text Then '主键修改，判断主键是否重复
If dcountlink("任务名称" "常见任务表" "任务名称='" & Text1(0) & "'" 0) > 0 Then
MsgBox "该任务名称已存在，请修改后重试"
Exit Sub
End If
End If
'满足条件添加记录
'----------------------------------
'连接数据库并更新
Dim update_conn As New ADODB.Connection
Dim update_rs As New ADODB.Recordset
With update_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
Dim update_sql As String
update_sql = "Select * From 常见任务表 Where 任务名称='" & key_data & "'"
update_rs.Open update_sql update_conn adOpenKeyset adLockOptimistic
'--字段更新
On Error Resume Next
With update_rs
!任务名称 = Text1(0).Text '新记录赋值
End With
update_rs.Update
update_rs.Close
Set update_rs = Nothing
update_conn.Close
Set update_conn = Nothing
key_data = Text1(0) '主键赋值
MsgBox "更新完成！"
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Text1(0).SetFocus '第一个录入数据控件获得焦点
'----------------------------------
Else
MsgBox "任务名称不能为空"
Exit Sub
End If
End If
Exit Sub
保存失败错误:
MsgBox Err.Description
End Sub
Private Sub Command取消_Click()
frm_datatype = 5
Call changetitle(frm_datatype)
Dim i '清空控件中的数据
For i = 1 To Text1.Count
Text1(i - 1).Text = ""
Next i
'点击取消时显示全部记录，清空条件
search_filter = ""
Adodc1.Refresh
DataGrid1.Refresh
End Sub
Private Sub Command删除_Click()
On Error GoTo 删除失败错误
Dim del_data As String
del_data = DataGrid1.Columns(0).Text
If MsgBox("是否删除任务名称为【" & del_data & "】 的记录？" vbYesNo "提示") <> vbYes Then '删除前提醒
Exit Sub
End If
'执行删除操作
Dim del_conn As New ADODB.Connection
Dim del_sql As String
del_sql = "delete from 常见任务表 Where 任务名称='" & del_data & "'" '定义删除sql语句
With del_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
.Execute del_sql '执行删除
End With
del_conn.Close
Set del_conn = Nothing
MsgBox "删除成功"
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Exit Sub
删除失败错误:
MsgBox Err.Description
End Sub
Private Sub Command添加_Click()
frm_datatype = 1
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件取消锁定可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus '第一个控件获得焦点
End Sub
Private Sub Command修改_Click()
key_data = 0
frm_datatype = 2
Call changetitle(frm_datatype)
End Sub
Private Sub DataGrid1_DblClick()
If frm_datatype <> 2 Then '判断是否为修改状态
MsgBox "需要修改数据，请先进入修改状态"
Exit Sub
End If
Dim i
For i = 0 To Text1.UBound '获取选择记录的数据
Text1(i).Text = DataGrid1.Columns(i).Text
Next i
'解除锁定（数据可编辑）
For i = 0 To Text1.UBound
Text1(i).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus
key_data = Text1(0).Text '主键赋值
End Sub
Private Sub Form_Load() '窗体加载
frm_title = "常见任务管理" '赋值标题到变量
frm_datatype = 5 '设置窗体当前管理数据类型
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件锁定不可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = True
Next i
Adodc1.Refresh '刷新
End Sub
Private Sub Text1_GotFocus(Index As Integer) '文本框获得焦点，背景色修改，选中原有文本
Text1(Index).BackColor = &HFFFF00
Text1(Index).SelStart = 0
Text1(Index).SelLength = Len(Text1(Index))
End Sub
Private Sub Text1_LostFocus(Index As Integer) '文本框失去焦点设计填充颜色（恢复）
Text1(Index).BackColor = &H80000005
End Sub
Sub changetitle(ByVal frmdatatype As Integer) '根据状态显示不同标题，设置按钮状态
Select Case frmdatatype
Case 1 '添加
Me.Caption = frm_title & "（添加）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 2 '添加
Me.Caption = frm_title & "（修改）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 3 '删除
Me.Caption = frm_title
Case 5 '取消
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = True
Me.Command修改.Enabled = True
Me.Command保存.Enabled = False
Me.Command取消.Enabled = True
Me.Command删除.Enabled = True
key_data = 0
'锁定所有控件
Dim i
For i = 0 To Text1.UBound
Text1(i).Locked = True
Next i
Case Else
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = False
Me.Command取消.Enabled = False
Me.Command删除.Enabled = False
End Select
End Sub
常见任务选择
Private Sub Command查询_Click()
If Text(0).Text <> "" Then
Adodc1.RecordSource = "Select * From 常见任务表 where 任务名称 like '%" & Text(0).Text & "%'"
Else
Adodc1.RecordSource = "Select * From 常见任务表"
End If
Adodc1.Refresh
DataGrid1.Refresh
DataGrid1.SetFocus
End Sub
Private Sub Command全部_Click()
Adodc1.RecordSource = "Select * From 常见任务表"
Adodc1.Refresh
DataGrid1.Refresh
DataGrid1.SetFocus
End Sub
Private Sub Command选择_Click()
On Error Resume Next
Dim i
For i = 0 To Forms.Count - 1
If Forms(i).Name = rw_formname Then
Forms(i).Text(0) = DataGrid1.Columns(0).Text
End If
Next i
Unload Me
End Sub
Private Sub Form_Load()
Adodc1.CommandType = adCmdUnknown
End Sub
负责人
Public frm_title As String '存储窗体标题
Public frm_datatype As Integer '存储当前管理状态（添加，修改，查询）
Public key_data As String '存储修改主键
Dim search_filter As String '存储筛选条件
Dim search_order As String '存储排序条件
Private Sub Command保存_Click()
On Error GoTo 保存失败错误
'==为添加状态时
If frm_datatype = 1 Then
'判断数据不能为空
If Text1(0).Text <> "" Then
'满足条件添加记录
'----------------------------------
Dim add_conn As New ADODB.Connection '连接数据
Dim add_rs As New ADODB.Recordset
With add_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
add_rs.Open "负责人表" add_conn adOpenKeyset adLockOptimistic '连接表生成记录集
add_rs.AddNew '添加记录
On Error Resume Next
add_rs!负责人 = Text1(0).Text '新记录赋值
add_rs.Update '更新
add_rs.Close '关闭清空记录集和连接
Set add_rs = Nothing
add_conn.Close
Set add_conn = Nothing
MsgBox "添加完成"
Text1(0).Text = ""
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Text1(0).SetFocus '第一个录入数据控件获得焦点继续录入
'----------------------------------
Else
MsgBox "负责人不能为空"
Exit Sub
End If
End If
'========================================================================为修改状态时
If frm_datatype = 2 Then
'判断数据不能为空
If Text1(0).Text <> "" Then
'判断主键不能重复
If key_data <> Text1(0).Text Then '主键修改，判断主键是否重复
If dcountlink("负责人" "负责人表" "负责人='" & Text1(0) & "'" 0) > 0 Then
MsgBox "该负责人已存在，请修改后重试"
Exit Sub
End If
End If
'满足条件添加记录
'----------------------------------
'连接数据库并更新
Dim update_conn As New ADODB.Connection
Dim update_rs As New ADODB.Recordset
With update_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
Dim update_sql As String
update_sql = "Select * From 负责人表 Where 负责人='" & key_data & "'"
update_rs.Open update_sql update_conn adOpenKeyset adLockOptimistic
'--字段更新
On Error Resume Next
With update_rs
!负责人 = Text1(0).Text '新记录赋值
End With
update_rs.Update
update_rs.Close
Set update_rs = Nothing
update_conn.Close
Set update_conn = Nothing
key_data = Text1(0) '主键赋值
MsgBox "更新完成！"
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Text1(0).SetFocus '第一个录入数据控件获得焦点
'----------------------------------
Else
MsgBox "负责人不能为空"
Exit Sub
End If
End If
Exit Sub
保存失败错误:
MsgBox Err.Description
End Sub
Private Sub Command取消_Click()
frm_datatype = 5
Call changetitle(frm_datatype)
Dim i '清空控件中的数据
For i = 1 To Text1.Count
Text1(i - 1).Text = ""
Next i
'点击取消时显示全部记录，清空条件
search_filter = ""
Adodc1.Refresh
DataGrid1.Refresh
End Sub
Private Sub Command删除_Click()
On Error GoTo 删除失败错误
Dim del_data As String
del_data = DataGrid1.Columns(0).Text
If MsgBox("是否删除负责人为【" & del_data & "】 的记录？" vbYesNo "提示") <> vbYes Then '删除前提醒
Exit Sub
End If
'执行删除操作
Dim del_conn As New ADODB.Connection
Dim del_sql As String
del_sql = "delete from 负责人表 Where 负责人='" & del_data & "'" '定义删除sql语句
With del_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
.Execute del_sql '执行删除
End With
del_conn.Close
Set del_conn = Nothing
MsgBox "删除成功"
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Exit Sub
删除失败错误:
MsgBox Err.Description
End Sub
Private Sub Command添加_Click()
frm_datatype = 1
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件取消锁定可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus '第一个控件获得焦点
End Sub
Private Sub Command修改_Click()
key_data = 0
frm_datatype = 2
Call changetitle(frm_datatype)
End Sub
Private Sub DataGrid1_DblClick()
If frm_datatype <> 2 Then '判断是否为修改状态
MsgBox "需要修改数据，请先进入修改状态"
Exit Sub
End If
Dim i
For i = 0 To Text1.UBound '获取选择记录的数据
Text1(i).Text = DataGrid1.Columns(i).Text
Next i
'解除锁定（数据可编辑）
For i = 0 To Text1.UBound
Text1(i).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus
key_data = Text1(0).Text '主键赋值
End Sub
Private Sub Form_Load() '窗体加载
frm_title = "负责人管理" '赋值标题到变量
frm_datatype = 5 '设置窗体当前管理数据类型
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件锁定不可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = True
Next i
Adodc1.Refresh '刷新
End Sub
Private Sub Text1_GotFocus(Index As Integer) '文本框获得焦点，背景色修改，选中原有文本
Text1(Index).BackColor = &HFFFF00
Text1(Index).SelStart = 0
Text1(Index).SelLength = Len(Text1(Index))
End Sub
Private Sub Text1_LostFocus(Index As Integer) '文本框失去焦点设计填充颜色（恢复）
Text1(Index).BackColor = &H80000005
End Sub
Sub changetitle(ByVal frmdatatype As Integer) '根据状态显示不同标题，设置按钮状态
Select Case frmdatatype
Case 1 '添加
Me.Caption = frm_title & "（添加）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 2 '添加
Me.Caption = frm_title & "（修改）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 3 '删除
Me.Caption = frm_title
Case 5 '取消
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = True
Me.Command修改.Enabled = True
Me.Command保存.Enabled = False
Me.Command取消.Enabled = True
Me.Command删除.Enabled = True
key_data = 0
'锁定所有控件
Dim i
For i = 0 To Text1.UBound
Text1(i).Locked = True
Next i
Case Else
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = False
Me.Command取消.Enabled = False
Me.Command删除.Enabled = False
End Select
End Sub
个人信息
Private Sub Command保存_Click()
If Me.Text1(2).Text <> "" Then
If Me.Text1(2).Text <> "男" And Me.Text1(2).Text <> "女" Then
MsgBox "性别只能输入男或女"
Exit Sub
End If
End If
If MsgBox("是否更新个人信息？" vbYesNo "提示") = vbYes Then
Me.Adodc1.Recordset.Update
MsgBox "更新完成"
End If
End Sub
Private Sub Form_Load()
Me.Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;Persist Security Info=False"
Me.Adodc1.CommandType = adCmdUnknown
Me.Adodc1.RecordSource = "select * From 账号表 Where 账号='" & login_name & "'"
Me.Adodc1.Refresh '刷新
'显示权限
Check全部任务.Value = CInt(Adodc1.Recordset.Fields("全部任务").Value) * -1
Check任务查看.Value = CInt(Adodc1.Recordset.Fields("任务查看").Value) * -1
Check任务添加.Value = CInt(Adodc1.Recordset.Fields("任务添加").Value) * -1
Check任务更新.Value = CInt(Adodc1.Recordset.Fields("任务更新").Value) * -1
Check任务删除.Value = CInt(Adodc1.Recordset.Fields("任务删除").Value) * -1
Check常见任务管理.Value = CInt(Adodc1.Recordset.Fields("常见任务管理").Value) * -1
Check负责人管理.Value = CInt(Adodc1.Recordset.Fields("负责人管理").Value) * -1
Check任务类型管理.Value = CInt(Adodc1.Recordset.Fields("任务类型管理").Value) * -1
Check任务状态管理.Value = CInt(Adodc1.Recordset.Fields("任务状态管理").Value) * -1
End Sub
修改密码
Private Sub Command修改密码_Click()
On Error GoTo 操作失败错误
Dim lname As String
Dim opw As String
Dim npw As String
If Trim(Me.Text账号) <> "" Then '判断账号不能为空
lname = Trim(Me.Text账号)
Else
MsgBox "账号不能为空"
Exit Sub
End If
If Trim(Me.Textoldpw) <> "" Then '判断旧密码不能为空
opw = Trim(Me.Textoldpw)
Else
MsgBox "原密码不能为空"
Exit Sub
End If
If Trim(Me.Textnewpw) <> "" Then '判断新密码不能为空
npw = Trim(Me.Textnewpw)
Else
MsgBox "新密码不能为空"
Exit Sub
End If
If opw <> login_pw Then '判断原密码是否正确
MsgBox "原密码不正确"
Exit Sub
End If
If Len(Trim(Me.Textnewpw)) < 6 Then '判断密码长度不能小于6
MsgBox "密码长度不能小于6位！"
Exit Sub
End If
If opw = npw Then '新旧密码不能相同
MsgBox "新密码不能与原密码相同"
Exit Sub
End If
'修改密码操作
Dim Cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
With Cnn 'mdb格式连接
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
Dim rs_sql As String
rs_sql = "select * from 账号表 where 账号='" & login_name & "'" '查询该账号记录
rs.Open rs_sql Cnn adOpenDynamic adLockOptimistic
If rs.EOF = False Then '循环表的内容
rs.Fields("密码") = npw
rs.Update
login_pw = npw
MsgBox "修改密码完成"
Else
MsgBox "未找到该账号"
Exit Sub
End If
rs.Close
Set rs = Nothing
Cnn.Close
Set Cnn = Nothing
Exit Sub
操作失败错误:
MsgBox Err.Description
End Sub
Private Sub Form_Load()
Me.Text账号 = login_name '显示账号
End Sub
用户注册
Private Sub Command注册_Click()
On Error GoTo 错误提示
If Text1(0) = "" Or IsNull(Text1(0)) = True Then
MsgBox "账号值不能为空！"
Exit Sub
Else
If Len(Text1(0)) > 15 Then
MsgBox "账号不能超过15个字符！"
Exit Sub
End If
End If
If Text1(1) = "" Or IsNull(Text1(1)) = True Then
MsgBox "姓名值不能为空！"
Exit Sub
Else
If Len(Text1(1)) > 30 Then
MsgBox "姓名不能超过30个字符！"
Exit Sub
End If
End If
If Text1(2) = "" Or IsNull(Text1(2)) = True Then
MsgBox "性别值不能为空！"
Exit Sub
Else
End If
If Text1(3) = "" Or IsNull(Text1(3)) = True Then
MsgBox "联系方式不能为空！"
Exit Sub
Else
If Len(Text1(3)) > 30 Then
MsgBox "联系方式不能超过30个字符！"
Exit Sub
End If
End If
If Text1(4) = "" Or IsNull(Text1(4)) = True Then
MsgBox "角色不能为空！"
Exit Sub
Else
End If
If Text1(5) = "" Or IsNull(Text1(5)) = True Then
MsgBox "密码不能为空！"
Exit Sub
Else
If Len(Text1(5)) > 15 Then
MsgBox "密码不能超过15个字符！"
Exit Sub
End If
End If
If Text1(6) = "" Or IsNull(Text1(6)) = True Then
MsgBox "确认密码不能为空！"
Exit Sub
Else
End If
If Text1(5).Text <> Text1(6).Text Then
MsgBox "密码和确认密码不一致！"
Exit Sub
End If
'检查账号是否已存在
If dcountlink("账号" "账号表" "账号='" & Text1(1) & "'" 0) > 0 Then
MsgBox "该账号已存在，请修改后重试"
Exit Sub
End If
Dim add_conn As New ADODB.Connection
Dim add_rs As New ADODB.Recordset
With add_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
add_rs.Open "账号表" add_conn adOpenKeyset adLockOptimistic
add_rs.AddNew
On Error Resume Next
add_rs!账号.Value = Text1(0).Text
add_rs!姓名.Value = Text1(1).Text
add_rs!性别.Value = Text1(2).Text
add_rs!联系方式.Value = Text1(3).Text
add_rs!角色.Value = Text1(4).Text
add_rs!密码.Value = Text1(5).Text
add_rs!全部任务.Value = False
add_rs!任务查看.Value = True
add_rs!任务添加.Value = True
add_rs!任务更新.Value = True
add_rs!任务删除.Value = True
add_rs!常见任务管理.Value = False
add_rs!负责人管理.Value = False
add_rs!任务类型管理.Value = False
add_rs!任务状态管理.Value = False
add_rs.Update
add_rs.Close
Set add_rs = Nothing
add_conn.Close
Set add_conn = Nothing
MsgBox "注册完成"
Unload Me
Exit Sub
错误提示:
MsgBox Err.Description
End Sub
Private Sub Text1_DblClick(Index As Integer)
If Index = 2 Then
If Text1(2).Text = "男" Then
Text1(2).Text = "女"
Else
Text1(2).Text = "男"
End If
End If
End Sub
Private Sub Text1_LostFocus(Index As Integer)
If Text1(2).Text <> "男" And Text1(2).Text <> "女" Then
MsgBox "性别只能输入男或女"
Text1(2).Text = "男"
End If
End Sub
任务类型
Private Sub Command添加_Click()
frm_datatype = 1
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件取消锁定可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus '第一个控件获得焦点
End Sub
Private Sub Command修改_Click()
key_data = 0
frm_datatype = 2
Call changetitle(frm_datatype)
End Sub
Private Sub DataGrid1_DblClick()
If frm_datatype <> 2 Then '判断是否为修改状态
MsgBox "需要修改数据，请先进入修改状态"
Exit Sub
End If
Dim i
For i = 0 To Text1.UBound '获取选择记录的数据
Text1(i).Text = DataGrid1.Columns(i).Text
Next i
'解除锁定（数据可编辑）
For i = 0 To Text1.UBound
Text1(i).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus
key_data = Text1(0).Text '主键赋值
End Sub
Private Sub Form_Load() '窗体加载
frm_title = "任务类型管理" '赋值标题到变量
frm_datatype = 5 '设置窗体当前管理数据类型
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件锁定不可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = True
Next i
Adodc1.Refresh '刷新
End Sub
Private Sub Text1_GotFocus(Index As Integer) '文本框获得焦点，背景色修改，选中原有文本
Text1(Index).BackColor = &HFFFF00
Text1(Index).SelStart = 0
Text1(Index).SelLength = Len(Text1(Index))
End Sub
Private Sub Text1_LostFocus(Index As Integer) '文本框失去焦点设计填充颜色（恢复）
Text1(Index).BackColor = &H80000005
End Sub
Sub changetitle(ByVal frmdatatype As Integer) '根据状态显示不同标题，设置按钮状态
Select Case frmdatatype
Case 1 '添加
Me.Caption = frm_title & "（添加）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 2 '添加
Me.Caption = frm_title & "（修改）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 3 '删除
Me.Caption = frm_title
Case 5 '取消
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = True
Me.Command修改.Enabled = True
Me.Command保存.Enabled = False
Me.Command取消.Enabled = True
Me.Command删除.Enabled = True
key_data = 0
'锁定所有控件
Dim i
For i = 0 To Text1.UBound
Text1(i).Locked = True
Next i
Case Else
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = False
Me.Command取消.Enabled = False
Me.Command删除.Enabled = False
End Select
End Sub
任务状态
Public frm_title As String '存储窗体标题
Public frm_datatype As Integer '存储当前管理状态（添加，修改，查询）
Public key_data As String '存储修改主键
Dim search_filter As String '存储筛选条件
Dim search_order As String '存储排序条件
Private Sub Command保存_Click()
On Error GoTo 保存失败错误
'========================================================================为添加状态时
If frm_datatype = 1 Then
'判断数据不能为空
If Text1(0).Text <> "" Then
'满足条件添加记录
'----------------------------------
Dim add_conn As New ADODB.Connection '连接数据
Dim add_rs As New ADODB.Recordset
With add_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
add_rs.Open "任务状态表" add_conn adOpenKeyset adLockOptimistic '连接表生成记录集
add_rs.AddNew '添加记录
On Error Resume Next
add_rs!任务状态 = Text1(0).Text '新记录赋值
add_rs.Update '更新
add_rs.Close '关闭清空记录集和连接
Set add_rs = Nothing
add_conn.Close
Set add_conn = Nothing
MsgBox "添加完成"
Text1(0).Text = ""
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Text1(0).SetFocus '第一个录入数据控件获得焦点继续录入
'----------------------------------
Else
MsgBox "任务状态不能为空"
Exit Sub
End If
End If
'========================================================================为修改状态时
If frm_datatype = 2 Then
'判断数据不能为空
If Text1(0).Text <> "" Then
'判断主键不能重复
If key_data <> Text1(0).Text Then '主键修改，判断主键是否重复
If dcountlink("任务状态" "任务状态表" "任务状态='" & Text1(0) & "'" 0) > 0 Then
MsgBox "该任务状态已存在，请修改后重试"
Exit Sub
End If
End If
'满足条件添加记录
'----------------------------------
'连接数据库并更新
Dim update_conn As New ADODB.Connection
Dim update_rs As New ADODB.Recordset
With update_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
Dim update_sql As String
update_sql = "Select * From 任务状态表 Where 任务状态='" & key_data & "'"
update_rs.Open update_sql update_conn adOpenKeyset adLockOptimistic
'--字段更新
On Error Resume Next
With update_rs
!任务状态 = Text1(0).Text '新记录赋值
End With
update_rs.Update
update_rs.Close
Set update_rs = Nothing
update_conn.Close
Set update_conn = Nothing
key_data = Text1(0) '主键赋值
MsgBox "更新完成！"
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Text1(0).SetFocus '第一个录入数据控件获得焦点
'----------------------------------
Else
MsgBox "任务状态不能为空"
Exit Sub
End If
End If
Exit Sub
保存失败错误:
MsgBox Err.Description
End Sub
Private Sub Command取消_Click()
frm_datatype = 5
Call changetitle(frm_datatype)
Dim i '清空控件中的数据
For i = 1 To Text1.Count
Text1(i - 1).Text = ""
Next i
'点击取消时显示全部记录，清空条件
search_filter = ""
Adodc1.Refresh
DataGrid1.Refresh
End Sub
Private Sub Command删除_Click()
On Error GoTo 删除失败错误
Dim del_data As String
del_data = DataGrid1.Columns(0).Text
If MsgBox("是否删除任务状态为【" & del_data & "】 的记录？" vbYesNo "提示") <> vbYes Then '删除前提醒
Exit Sub
End If
'执行删除操作
Dim del_conn As New ADODB.Connection
Dim del_sql As String
del_sql = "delete from 任务状态表 Where 任务状态='" & del_data & "'" '定义删除sql语句
With del_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
.Execute del_sql '执行删除
End With
del_conn.Close
Set del_conn = Nothing
MsgBox "删除成功"
Adodc1.Refresh '刷新显示结果
DataGrid1.Refresh
Exit Sub
删除失败错误:
MsgBox Err.Description
End Sub
Private Sub Command添加_Click()
frm_datatype = 1
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件取消锁定可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus '第一个控件获得焦点
End Sub
Private Sub Command修改_Click()
key_data = 0
frm_datatype = 2
Call changetitle(frm_datatype)
End Sub
Private Sub DataGrid1_DblClick()
If frm_datatype <> 2 Then '判断是否为修改状态
MsgBox "需要修改数据，请先进入修改状态"
Exit Sub
End If
Dim i
For i = 0 To Text1.UBound '获取选择记录的数据
Text1(i).Text = DataGrid1.Columns(i).Text
Next i
'解除锁定（数据可编辑）
For i = 0 To Text1.UBound
Text1(i).Locked = False
Next i
Text1(0).Locked = False
Text1(0).SetFocus
key_data = Text1(0).Text '主键赋值
End Sub
Private Sub Form_Load() '窗体加载
frm_title = "任务状态管理" '赋值标题到变量
frm_datatype = 5 '设置窗体当前管理数据类型
Call changetitle(frm_datatype)
Dim i
For i = 1 To Text1.Count '控件锁定不可录入数据
Text1(i - 1).Text = ""
Text1(i - 1).Locked = True
Next i
Adodc1.Refresh '刷新
End Sub
Private Sub Text1_GotFocus(Index As Integer) '文本框获得焦点，背景色修改，选中原有文本
Text1(Index).BackColor = &HFFFF00
Text1(Index).SelStart = 0
Text1(Index).SelLength = Len(Text1(Index))
End Sub
Private Sub Text1_LostFocus(Index As Integer) '文本框失去焦点设计填充颜色（恢复）
Text1(Index).BackColor = &H80000005
End Sub
Sub changetitle(ByVal frmdatatype As Integer) '根据状态显示不同标题，设置按钮状态
Select Case frmdatatype
Case 1 '添加
Me.Caption = frm_title & "（添加）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 2 '添加
Me.Caption = frm_title & "（修改）"
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = True
Me.Command取消.Enabled = True
Me.Command删除.Enabled = False
Case 3 '删除
Me.Caption = frm_title
Case 5 '取消
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = True
Me.Command修改.Enabled = True
Me.Command保存.Enabled = False
Me.Command取消.Enabled = True
Me.Command删除.Enabled = True
key_data = 0
'锁定所有控件
Dim i
For i = 0 To Text1.UBound
Text1(i).Locked = True
Next i
Case Else
Me.Caption = frm_title
'按钮状态设置
Me.Command添加.Enabled = False
Me.Command修改.Enabled = False
Me.Command保存.Enabled = False
Me.Command取消.Enabled = False
Me.Command删除.Enabled = False
End Select
End Sub
公共变量
Public login_name As String '账号
Public login_pw As String '密码
Public user_name As String '姓名
Public user_role As String '角色
'权限
Public 全部任务权限 As Boolean
Public 任务查看权限 As Boolean
Public 任务添加权限 As Boolean
Public 任务更新权限 As Boolean
Public 任务删除权限 As Boolean
Public 常见任务管理权限 As Boolean
Public 负责人管理权限 As Boolean
Public 任务类型管理权限 As Boolean
Public 任务状态管理权限 As Boolean
'-------------------------------------------
'任务
Public rw_filter As String '筛选
Public rw_order As String '排序
Public rw_num As Long '主键
Public rw_formname As String '任务选择
公共函数过程
Public Function dlookuplink(ByVal rsfieldname As String ByVal rstable As String ByVal rscondition As String ByVal nullvalue) As String '查询指定记录返回值
Dim dlookuplink_conn As New ADODB.Connection
Dim dlookuplink_rs As New ADODB.Recordset
dlookuplink = nullvalue
On Error GoTo 查找记录出错
With dlookuplink_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
dlookuplink_rs.CursorLocation = adUseClient
Dim dlookuplink_sql As String
If rscondition <> "" Then
dlookuplink_sql = "Select * From " & rstable & " where " & rscondition
Else
dlookuplink_sql = "Select * From " & rstable
End If
dlookuplink_rs.Open dlookuplink_sql dlookuplink_conn adOpenDynamic adLockOptimistic
If dlookuplink_rs.EOF = False Then
dlookuplink = dlookuplink_rs.Fields(rsfieldname)
Else
dlookuplink = nullvalue
End If
dlookuplink_rs.Close
Set dlookuplink_rs = Nothing
dlookuplink_conn.Close
Set dlookuplink_conn = Nothing
Exit Function
查找记录出错:
dlookuplink_rs.Close
Set dlookuplink_rs = Nothing
dlookuplink_conn.Close
Set dlookuplink_conn = Nothing
dlookuplink = nullvalue
MsgBox Err.Description
End Function
Public Function dcountlink(ByVal rsfieldname As String ByVal rstable As String ByVal rscondition As String ByVal nullvalue As Long) As Long '查询记录数量
Dim dcountlink_conn As New ADODB.Connection
Dim dcountlink_rs As New ADODB.Recordset
dcountlink = nullvalue
On Error GoTo 查找记录出错
With dcountlink_conn
.ConnectionString = "Provider = microsoft.jet.oledb.4.0;data source=" & App.Path & "\db_rw.mdb;Jet OLEDB:DataBase password=abc123;persist security info=false"
.Open
End With
dcountlink_rs.CursorLocation = adUseClient
Dim dcountlink_sql As String
If rscondition <> "" Then
dcountlink_sql = "Select * From " & rstable & " where " & rscondition
Else
dcountlink_sql = "Select * From " & rstable
End If
dcountlink_rs.Open dcountlink_sql dcountlink_conn adOpenDynamic adLockOptimistic
If dcountlink_rs.EOF = False Then
dcountlink = dcountlink_rs.RecordCount
Else
dcountlink = nullvalue
End If
dcountlink_rs.Close
Set dcountlink_rs = Nothing
dcountlink_conn.Close
Set dcountlink_conn = Nothing
Exit Function
查找记录出错:
dcountlink_rs.Close
Set dcountlink_rs = Nothing
dcountlink_conn.Close
Set dcountlink_conn = Nothing
dcountlink = nullvalue
MsgBox Err.Description
End Function
Public Function FileFolderExists(strFullPath As String) As Boolean '判断文件夹是否存在
On Error GoTo EarlyExit
If Not Dir(strFullPath vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
