前端程式
前端程式開發平台為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