frmoprsys.frm
来自「一套简易的MIS系统。带SQLServer数据库。供参考。」· FRM 代码 · 共 876 行 · 第 1/2 页
FRM
876 行
Left = 4920
TabIndex = 9
Top = 4560
Width = 1425
_ExtentX = 2514
_ExtentY = 661
Icon = "frmOprSys.frx":3338
Caption = "全部选定(&S)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin CSCommand.Command cmdCancel
Height = 375
Left = 6360
TabIndex = 10
Top = 4560
Width = 1425
_ExtentX = 2514
_ExtentY = 661
Icon = "frmOprSys.frx":3492
Caption = "全部清除(&L)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin CSCommand.Command Command1
Height = 375
Left = 7800
TabIndex = 27
Top = 4560
Width = 1425
_ExtentX = 2514
_ExtentY = 661
Icon = "frmOprSys.frx":3A2C
Caption = "保存权限(&V)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin ComctlLib.ImageList ImageList2
Left = 3000
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 327682
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
NumListImages = 1
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "frmOprSys.frx":3FC6
Key = ""
EndProperty
EndProperty
End
Begin ComctlLib.ImageList ImageList1
Left = 2400
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 32
ImageHeight = 32
MaskColor = 12632256
_Version = 327682
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
NumListImages = 5
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "frmOprSys.frx":41A0
Key = ""
EndProperty
BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "frmOprSys.frx":437A
Key = ""
EndProperty
BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "frmOprSys.frx":4554
Key = ""
EndProperty
BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "frmOprSys.frx":472E
Key = ""
EndProperty
BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "frmOprSys.frx":4908
Key = ""
EndProperty
EndProperty
End
End
Attribute VB_Name = "frmOprSys"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdCancel_Click()
Dim iIndex As Integer
For iIndex = 0 To chkLimit.Count - 1
chkLimit(iIndex).Value = 0
Next
End Sub
Private Sub cmdClose_Click()
'返回
tBackMain Me
End Sub
Private Sub cmdFunction_Click()
Dim iIndex As Integer
For iIndex = 0 To chkLimit.Count - 1
chkLimit(iIndex).Value = 1
Next
End Sub
Private Sub cmdGClose_Click()
Picture1.Visible = False
End Sub
Private Sub cmdMain_Click()
Dim strMaxCode As String
On Error GoTo ErrInfo
If optMain.Value = True Then
If tWhileCode("tbCCFunction", "fName", Trim(txtName.Text)) = False Then
MsgBox "信息重复！", vbInformation, "提示："
Exit Sub
End If
DBCN.Execute "Insert Into tbCCFunction(fCode,fName,fLevel) Select '" & tBigCode("tbCCFunction", "fCode") & "', " _
& " '" & txtName.Text & "',1 "
'显示主要权限
'显示基础信息
Call getMain
MsgBox "主功能添加完成！", vbInformation, "提示："
txtName.Text = ""
txtName.SetFocus
Exit Sub
End If
If optList.Value = True Then
If tWhileCode("tbCCFunction", "fName", Trim(txtName1.Text)) = False Then
MsgBox "信息重复！", vbInformation, "提示："
Exit Sub
End If
DBCN.Execute "Insert Into tbCCFunction(fCode,fName,fLevel) Select '" & tString(cmbMain.Text, "[", "]", 0) & getMaxCode("") & "'," _
& " '" & Trim(txtName1.Text) & "',2 "
MsgBox "功能添加完成！", vbInformation, "提示："
txtName1.Text = ""
txtName1.SetFocus
Exit Sub
End If
Exit Sub
ErrInfo:
MsgBox Err.Description, vbInformation, "提示："
End Sub
Private Sub cmdOK_Click()
On Error GoTo ErrInfo
If txtOpr(0).Text = "" Then
MsgBox "编码错误！", vbInformation, "提示："
txtOpr(0).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
End If
If txtOpr(1).Text = "" Then
MsgBox "名称错误！", vbInformation, "提示："
txtOpr(1).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
End If
With uShareInfo
.strCode = txtOpr(0).Text
.strName = txtOpr(1).Text
End With
If tOperator(uShareInfo, iAdd_Update) = False Then
MsgBox "数据添加失败！", vbInformation, "提示："
Exit Sub
End If
MsgBox "数据添加成功！", vbInformation, "提示："
txtOpr(0).Text = ""
txtOpr(1).Text = ""
'显示操作员信息
lstOpr.ListItems.Clear
Call getOprInfo
txtOpr(0).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
ErrInfo:
MsgBox Err.Description, vbInformation, "提示："
End Sub
Private Sub Command1_Click()
Dim iIndex As Integer
Dim iLimit() As Integer
On Error GoTo ErrInfo
ReDim iLimit(chkLimit.Count - 1)
For iIndex = 0 To chkLimit.Count - 1
If chkLimit(iIndex).Visible = True Then
If chkLimit(iIndex).Value = 1 Then
iLimit(iIndex) = 1
Else
iLimit(iIndex) = 0
End If
End If
Next
If tOprLimited(strOpr_Update, iLimit, chkLimit.Count - 1) = False Then
MsgBox "权限处理失败！", vbInformation, "提示："
Exit Sub
End If
MsgBox "权限设置完成！", vbInformation, "提示："
Exit Sub
ErrInfo:
MsgBox Err.Description, vbInformation, "提示："
End Sub
Private Sub Form_Load()
' Picture1.Visible = False
'计算窗体显示位置
tFormSpace frmMain, Me, uWindows
'重新创建表
Call tLimitTab(chkLimit.Count - 1)
'显示基础信息
' Call getMain
'显示操作员信息
Call getOprInfo
End Sub
'显示操作员信息
Private Function getOprInfo()
Dim iIndex As Integer
Dim rsTemp As New ADODB.Recordset
Dim strSQL As String
Set rsTemp = DBCN.Execute("Select * from tbCcOper Order By Oper_id ")
If rsTemp.EOF = False Then
With lstOpr
.View = lvwIcon
.LabelEdit = lvwManual
End With
Set lstOpr.Icons = ImageList3
iIndex = 1
Do Until rsTemp.EOF
If rsTemp.Fields("Instate") = 0 Then
lstOpr.ListItems.Add iIndex, , rsTemp.Fields("Oper_Name") & "[" & rsTemp.Fields("Oper_ID") & "]", 3
Else
lstOpr.ListItems.Add iIndex, , rsTemp.Fields("Oper_Name") & "[" & rsTemp.Fields("Oper_ID") & "]", 7
End If
rsTemp.MoveNext
iIndex = iIndex + 1
Loop
End If
End Function
Private Sub lstOpr_Click()
strOpr_Update = tString(lstOpr.SelectedItem.Text, "[", "]", 0)
getLimited strOpr_Update
End Sub
'显示权限
Private Function getLimited(strOpr As String)
Dim iIndex As Integer
For iIndex = 0 To chkLimit.Count - 1
chkLimit(iIndex).Value = tReadLimit(strOpr, iIndex)
Next
End Function
''''显示权限
'''Private Sub getMain()
'''
'''' Dim rsTemp As New ADODB.Recordset
'''' Set rsTemp = DBCN.Execute("Select * from tbCCFunction Where Len(fCode)=4 Order By fCode")
'''' If rsTemp.EOF = False Then
'''' cmbMain.Clear
'''' Do Until rsTemp.EOF
'''' cmbMain.AddItem rsTemp.Fields("fName") & "[" & rsTemp.Fields("fCode") & "]"
'''' rsTemp.MoveNext
'''' Loop
'''' cmbMain.Text = cmbMain.List(0)
'''' End If
''' Dim tvList As Node
'''' Set tvOpr.ImageList = ImageList3
''' With tvOpr
''' .Nodes.Clear
''' .Checkboxes = True
''' .LabelEdit = tvwManual
''' End With
''' Set tvList = tvOpr.Nodes.Add(, , , "部门管理", 1)
'''' Set tvList = tvOpr.Nodes.Add()
'''' Set SysTree = TreeView1.Nodes.Add(, , , "部门管理", 1)
''' tvOpr.Nodes(1).Expanded = True
'''
'''End Sub
Private Sub txtOpr_GotFocus(iNdex As Integer)
txtOpr(iNdex).BackColor = &HC0FFC0
txtOpr(iNdex).ForeColor = vbRed
End Sub
Private Sub txtOpr_KeyDown(iNdex As Integer, KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyDown
If iNdex = txtOpr.Count - 1 Then Exit Sub
txtOpr(iNdex + 1).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
Case vbKeyUp
If iNdex = 0 Then Exit Sub
txtOpr(iNdex - 1).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
Case Else
Exit Sub
End Select
End Sub
Private Sub txtOpr_KeyPress(iNdex As Integer, KeyAscii As Integer)
Select Case KeyAscii
Case vbKeyReturn
Select Case iNdex
Case 0
If txtOpr(iNdex).Text = "" Then
If MsgBox("系统将自动生成最大编码？", vbInformation + vbYesNo, "提示：") = vbYes Then
txtOpr(iNdex).Text = tBigCode("tbCcOper", "Oper_id")
txtOpr(iNdex + 1).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
Else
txtOpr(iNdex).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
End If
End If
If tWhileCode("tbCcOper", "Oper_id", Format(Trim(txtOpr(iNdex).Text), "0000")) = False Then
MsgBox "编码重复！请检查您的输入是否正确？", vbInformation, "提示："
txtOpr(iNdex).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
Else
txtOpr(iNdex).Text = Format(txtOpr(iNdex).Text, "0000")
txtOpr(iNdex + 1).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
End If
Case 1
If txtOpr(iNdex).Text = "" Then
txtOpr(iNdex).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
End If
If tWhileCode("tbCcOper", "Oper_name", Trim(txtOpr(iNdex).Text)) = False Then
MsgBox "信息重复！请检查您的输入是否正确？", vbInformation, "提示："
txtOpr(iNdex).SetFocus
SendKeys "{Home}+{End}"
Exit Sub
Else
cmdOK.SetFocus
Exit Sub
End If
End Select
Case Else
Exit Sub
End Select
End Sub
Private Sub txtOpr_LostFocus(iNdex As Integer)
txtOpr(iNdex).BackColor = vbWhite
txtOpr(iNdex).ForeColor = vbBlack
End Sub
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?