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