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
