📄 frmdep.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmDep
BorderStyle = 1 'Fixed Single
Caption = "部门信息管理"
ClientHeight = 5760
ClientLeft = 45
ClientTop = 435
ClientWidth = 7875
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5760
ScaleWidth = 7875
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdQuit
Caption = "退出"
Height = 375
Left = 6840
TabIndex = 10
Top = 5160
Width = 855
End
Begin VB.CommandButton cmdModify
Caption = "修改"
Height = 375
Left = 4920
TabIndex = 9
Top = 5160
Width = 855
End
Begin VB.CommandButton cmdDel
Caption = "删除"
Height = 375
Left = 5880
TabIndex = 8
Top = 5160
Width = 855
End
Begin VB.CommandButton cmdAdd
Caption = "添加"
Height = 375
Left = 3960
TabIndex = 7
Top = 5160
Width = 855
End
Begin VB.TextBox txtDes
Height = 2775
Left = 5040
TabIndex = 6
Top = 1920
Width = 2535
End
Begin VB.TextBox txtName
Height = 375
Left = 5040
TabIndex = 4
Top = 1200
Width = 2535
End
Begin VB.TextBox txtId
Height = 375
Left = 5040
TabIndex = 2
Top = 480
Width = 2535
End
Begin MSComctlLib.TreeView trvDep
Height = 5175
Left = 240
TabIndex = 0
Top = 240
Width = 3375
_ExtentX = 5953
_ExtentY = 9128
_Version = 393217
Style = 6
Appearance = 1
End
Begin VB.Label Label5
Caption = "*"
ForeColor = &H000000FF&
Height = 255
Index = 1
Left = 4920
TabIndex = 12
Top = 1320
Width = 135
End
Begin VB.Label Label5
Caption = "*"
ForeColor = &H000000FF&
Height = 255
Index = 0
Left = 4920
TabIndex = 11
Top = 600
Width = 135
End
Begin VB.Label Label4
Caption = "部门功能描述（100字以内）"
Height = 615
Left = 3840
TabIndex = 5
Top = 2160
Width = 1215
End
Begin VB.Label Label3
Caption = "部 门 名 称"
Height = 375
Left = 3840
TabIndex = 3
Top = 1320
Width = 1095
End
Begin VB.Label Label2
Caption = "部 门 编 号"
Height = 255
Left = 3840
TabIndex = 1
Top = 600
Width = 1095
End
End
Attribute VB_Name = "frmDep"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' ******************************************************************************
'窗体公共变量定义
' ******************************************************************************
Option Explicit
Dim txtSQL As String
Dim txtTest As String
Dim rstDep As ADODB.Recordset
Dim results As Boolean
Dim str As String
Dim nodeDep As Node
Private Sub Form_Load()
If gUserName = "普通用户" Then
cmdAdd.Enabled = False
cmdDel.Enabled = False
cmdModify.Enabled = False
End If
trvDep.LineStyle = tvwRootLines
Call viewDataDep
MsgBox "！输入的编号必须是8位0，1数字的组合！", vbOKOnly + vbExclamation, "警告"
End Sub
Private Sub cmdAdd_Click()
'检验输入值不能为空
If txtIsNull(txtId) Then
MsgBox "*项目不能为空！", vbOKOnly + vbExclamation, "警告"
Exit Sub
Else
If Not ISEquelLen(txtId, 8) Then
MsgBox "编号必须是8位0，1数字的组合！", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
End If
If txtIsNull(txtName) Then
MsgBox "*项目不能为空！", vbOKOnly + vbExclamation, "警告"
Exit Sub
Else
If IsOverStringLen(txtName.Text, 20) Then
MsgBox "名称不能超过20位！", vbOKOnly + vbExclamation, "警告"
txtName.SetFocus
txtName.BackColor = BLUE
Exit Sub
End If
End If
txtTest = "select DepId from tbDep where DepId ='" + Trim(txtId.Text) + "'"
If DBExist(txtTest) <> 0 Then
MsgBox "编号已经存在，请重新输入！", vbOKOnly + vbExclamation, "警告"
txtId.BackColor = BLUE
Else
txtSQL = "insert into tbDep(DepId,DepName,Describe)" + "values('" + Trim(txtId.Text) + "','" + Trim(txtName.Text) + "','" + Trim(Me.txtDes.Text) + "')"
results = ExecuteSQL(txtSQL, rstDep, True)
Call viewDataDep
MsgBox "添加成功！", vbOKOnly + vbExclamation, "警告"
End If
End Sub
Private Sub cmdDel_Click()
'检验删除记录是否选定
If txtIsNull(txtId) Then
MsgBox "请选择删除的记录！", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
'提示警告信息
str = MsgBox("是否删除当前记录？", vbOKCancel, "删除当前记录")
If str = vbOK Then
txtTest = "select DepId from tbDep where DepId ='" + Trim(txtId.Text) + "'"
'检验此用户名是否已经存在
If DBExist(txtTest) = 0 Then
MsgBox "无此用户！", vbOKOnly + vbExclamation, "警告"
txtId.BackColor = BLUE
Else
txtTest = "select * from tbEmployee where DepId ='" + Trim(txtId.Text) + "'"
If DBExist(txtTest) <> 0 Then
MsgBox "该记录在职员表中被引用，不能删除！", vbOKOnly + vbExclamation, "警告"
txtId.BackColor = BLUE
Else
txtSQL = "delete from tbDep where DepId='" + Trim(txtId.Text) + "'"
results = ExecuteSQL(txtSQL, rstDep, True)
MsgBox "删除成功！", vbOKOnly + vbExclamation, "警告"
txtId.Text = ""
txtName.Text = ""
txtDes.Text = ""
Call viewDataDep
End If
End If
End If
End Sub
Private Sub cmdModify_Click()
'检验修改记录是否选定
If txtIsNull(txtId) Then
MsgBox "请选择需要修改的记录！", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
If txtIsNull(txtName) Then
MsgBox "部门名称不能为空录！", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
'提示警告信息
str = MsgBox("是否修改当前记录？", vbOKCancel, "删除当前记录")
If str = vbOK Then
txtId.Locked = True
txtTest = "select DepId from tbDep where DepId ='" + Trim(txtId.Text) + "'"
'检验此用户名是否已经存在
If DBExist(txtTest) = 0 Then
MsgBox "无此记录，请添加此记录或重新输入编号！", vbOKOnly + vbExclamation, "警告"
txtId.BackColor = BLUE
txtId.Locked = False
Else
If Not ISEquelLen(txtId, 8) Then
MsgBox "编号必须是8位0，1数字的组合！", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
If IsOverStringLen(txtName.Text, 20) Then
MsgBox " 部门名称不能超过20位！", vbOKOnly + vbExclamation, "警告"
txtName.SetFocus
txtName.BackColor = BLUE
Exit Sub
End If
If IsOverStringLen(txtDes.Text, 100) Then
MsgBox " 部门描述不能超过100字！", vbOKOnly + vbExclamation, "警告"
txtDes.SetFocus
txtDes.BackColor = BLUE
Exit Sub
End If
txtSQL = "update tbDep set DepId = '" + Trim(txtId.Text) + "', DepName = '" + Trim(txtName.Text) + "',Describe = '" + Trim(txtDes.Text) + "'where DepId='" + Trim(txtId.Text) + "'"
results = ExecuteSQL(txtSQL, rstDep, True)
MsgBox " 修改成功！", vbOKOnly + vbExclamation, "警告"
Call viewDataDep
txtId.Locked = False
End If
End If
End Sub
Private Sub cmdQuit_Click()
Unload Me
End Sub
Private Sub trvDep_NodeClick(ByVal Node As MSComctlLib.Node)
'点击树型结构时，在右边的文本框中显示出对应的信息
txtName.Text = Node.Text
txtSQL = "select DepId ,DepName ,Describe from tbDep where DepName = '" & Node.Text & "' order by DepId"
results = ExecuteSQL(txtSQL, rstDep, False)
If rstDep.RecordCount <> 1 Then
MsgBox "部门名称重复，与编号不对应，请修改！", vbOKOnly + vbExclamation, "警告"
Else
Me.txtId.Text = rstDep.Fields(0)
Me.txtDes.Text = rstDep.Fields(2)
End If
End Sub
Private Sub txtDes_Change()
txtDes.BackColor = WHITE '当文本框内容改变时恢复白色背景
End Sub
Private Sub txtId_Change()
txtId.BackColor = WHITE '当文本框内容改变时恢复白色背景
End Sub
Private Sub txtName_Change()
txtName.BackColor = WHITE '当文本框内容改变时恢复白色背景
End Sub
' ******************************************************************************
'过程名：viewDataDep
'说 明：将部门信息显示在树型列表中, 其中编码规则为一级部门**000000，二级部门****0000，三级部门******00
'参 数：无
'返回值：无
' ******************************************************************************
Private Sub viewDataDep()
Dim i As Integer
On Error GoTo View_Error
'检索部门信息显示在树型列表中
Me.trvDep.Nodes.Clear
txtSQL = "select DepId ,DepName ,Describe from tbDep order by DepId"
results = ExecuteSQL(txtSQL, rstDep, False)
If rstDep.RecordCount <> 0 Then
For i = 0 To rstDep.RecordCount - 1
If StrComp(Mid(rstDep.Fields(0), 3, 4), "0000") = 0 Then
Set nodeDep = trvDep.Nodes.Add(, , "dep" + Left(rstDep.Fields(0), 2), _
rstDep.Fields(1))
Else
If StrComp(Mid(rstDep.Fields(0), 5, 2), "00") = 0 Then
Set nodeDep = trvDep.Nodes.Add("dep" + Left(rstDep.Fields(0), 2), _
tvwChild, "dep" + Left(rstDep.Fields(0), 4), rstDep.Fields(1))
Else
Set nodeDep = trvDep.Nodes.Add("dep" + Left(rstDep.Fields(0), 4), _
tvwChild, "dep" + Left(rstDep.Fields(0), 6), rstDep.Fields(1))
End If
End If
rstDep.MoveNext
Next
Else
MsgBox "没有部门信息！", vbOKOnly + vbExclamation, "警告"
End If
Exit Sub
View_Error:
MsgBox "部门编号输入有误,请检查数据库并修正记录！", vbOKOnly + vbExclamation, "警告"
Exit Sub
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -