📄 frmclerkright.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmClerkRight
BorderStyle = 1 'Fixed Single
Caption = "Set Right"
ClientHeight = 6165
ClientLeft = 30
ClientTop = 330
ClientWidth = 8220
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmClerkRight.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6165
ScaleWidth = 8220
StartUpPosition = 1 'CenterOwner
Begin VB.Frame frmClerk
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 5895
Left = 0
TabIndex = 12
Top = 0
Width = 2535
Begin MSComctlLib.ListView lsvRole
Height = 5655
Left = 60
TabIndex = 13
Top = 150
Width = 2415
_ExtentX = 4260
_ExtentY = 9975
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 0
End
End
Begin VB.Frame Frame3
Height = 5220
Left = 2640
TabIndex = 10
Top = 690
Width = 3810
Begin MSComctlLib.TreeView tvwRight
Height = 4875
Left = 75
TabIndex = 11
Top = 240
Width = 3660
_ExtentX = 6456
_ExtentY = 8599
_Version = 393217
HideSelection = 0 'False
Indentation = 176
LabelEdit = 1
Style = 7
ImageList = "imglstMenu"
Appearance = 1
End
End
Begin VB.Frame Frame1
Height = 5235
Left = 6465
TabIndex = 0
Top = 690
Width = 1710
Begin VB.CommandButton cmdCancel
Caption = "Cancel"
Height = 420
Left = 120
TabIndex = 4
Top = 1020
Width = 1485
End
Begin VB.CommandButton cmdGrantAll
Caption = "Grant All"
Height = 420
Left = 120
TabIndex = 3
Top = 2265
Width = 1485
End
Begin VB.CommandButton cmdRevokeAll
Caption = "Recoke All"
Height = 420
Left = 120
TabIndex = 2
Top = 2985
Width = 1485
End
Begin VB.CommandButton cmdOK
Caption = "OK"
Height = 420
Left = 120
TabIndex = 1
Top = 300
Width = 1485
End
End
Begin VB.Frame Frame2
Height = 570
Left = 2670
TabIndex = 5
Top = 0
Width = 5490
Begin VB.TextBox txtCode
BackColor = &H80000004&
Height = 300
Left = 1035
Locked = -1 'True
TabIndex = 7
Top = 180
Width = 1545
End
Begin VB.TextBox txtName
BackColor = &H80000004&
Height = 300
Left = 3810
Locked = -1 'True
TabIndex = 6
Top = 180
Width = 1545
End
Begin VB.Label Label1
Caption = "UserCode"
Height = 225
Left = 165
TabIndex = 9
Top = 240
Width = 900
End
Begin VB.Label Label2
Caption = "UserName"
Height = 225
Left = 2895
TabIndex = 8
Top = 255
Width = 900
End
End
Begin MSComctlLib.ImageList imglstMenu
Left = 2550
Top = 105
_ExtentX = 794
_ExtentY = 794
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 5
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClerkRight.frx":27A2
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClerkRight.frx":2AF4
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClerkRight.frx":2E46
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClerkRight.frx":3398
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClerkRight.frx":37EC
Key = ""
EndProperty
EndProperty
End
End
Attribute VB_Name = "frmClerkRight"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'增加一个节点
Private Sub AddNode(ByVal sParentCode As String, ByVal sCode As String)
Dim sParent As String
Dim i As Long
Dim tNode As node
Dim sSQL As String
Dim tmpRight As Recordset
sParent = sParentCode
sSQL = "select a.*,b.empower from sysfun a,sysacc b where a.parentc='" & sParent & "' and a.funcode=b.funcode and b.rolcode='" & sCode & "'"
Set tmpRight = Acs_cnt.Execute(sSQL)
With tmpRight
Do While Not .EOF
i = CInt(tmpRight!empower)
Set tNode = tvwRight.Nodes.Add(TREEKEY & sParent, tvwChild, TREEKEY & tmpRight!funcode, tmpRight!shodesc, IIf(i = 1, 2, 3))
.MoveNext
Loop
End With
tmpRight.Close
Set tmpRight = Nothing
End Sub
Private Sub RefershRight(ByVal sCode As String)
Dim sSQL As String
Dim rstRight As Recordset
Dim i As Long
With tvwRight
.Nodes.Clear
.Nodes.Add , , "r", "Root", 1
End With
sSQL = "Select a.*,b.empower From sysfun a,sysacc b where a.funcode=b.funcode and a.parentc='F' and b.rolcode='" & sCode & "'"
Set rstRight = Acs_cnt.Execute(sSQL)
If Not rstRight Is Nothing Then
Do While Not rstRight.EOF
i = CInt(rstRight!empower)
tvwRight.Nodes.Add "r", tvwChild, TREEKEY & rstRight!funcode, rstRight!shodesc, IIf(i = 1, 2, 3)
Call AddNode(rstRight!funcode, txtCode.Text)
rstRight.MoveNext
Loop
rstRight.Close
Set rstRight = Nothing
End If
End Sub
'初始化Form
Private Sub InitRight(ByVal sCode As String)
Dim sSQL As String
Dim rstRight As Recordset
Dim i As Long
With tvwRight
.Nodes.Clear
.Nodes.Add , , "r", "Root", 1
End With
sSQL = "Select a.*,b.empower From sysfun a,sysacc b where a.funcode=b.funcode and a.parentc='F' and b.rolcode='" & sCode & "'"
Set rstRight = Acs_cnt.Execute(sSQL)
If Not rstRight Is Nothing Then
Do While Not rstRight.EOF
i = CInt(rstRight!empower)
tvwRight.Nodes.Add "r", tvwChild, TREEKEY & rstRight!funcode, rstRight!shodesc, IIf(i = 1, 2, 3)
Call AddNode(rstRight!funcode, txtCode.Text)
rstRight.MoveNext
Loop
rstRight.Close
Set rstRight = Nothing
End If
End Sub
'设置节点及其子节点的Image
Private Sub SetNodeImage(ByVal mNode As node, ByVal nImg As Integer)
Dim tNode As node, i As Integer
If mNode Is Nothing Then Exit Sub
If mNode.Key = "r" Then Exit Sub
If mNode.Children > 0 Then
Set tNode = mNode.Child
Call SetNodeImage(tNode, nImg)
For i = 1 To mNode.Children - 1
Set tNode = tNode.Next
Call SetNodeImage(tNode, nImg)
Next i
End If
If mNode.Image = 2 Or mNode.Image = 3 Then
mNode.Image = nImg
End If
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdGrantAll_Click()
Dim i As Integer, tNode As node
If txtCode.Text = "" Then
Exit Sub
End If
If tvwRight.Nodes("r").Children <= 0 Then Exit Sub
Set tNode = tvwRight.Nodes("r").Child
Call SetNodeImage(tNode, 2)
For i = 1 To tvwRight.Nodes("r").Children - 1
Set tNode = tNode.Next
Call SetNodeImage(tNode, 2)
Next i
End Sub
Private Sub cmdOK_Click()
Dim tNode As node
Dim tNode2 As node
Dim sEmpower As String
Dim sRoleCode As String, sFunCode As String
Dim i As Integer
sRoleCode = txtCode.Text
If sRoleCode = "" Then
Exit Sub
End If
Set tNode = tvwRight.Nodes("r").Child
Do While Not tNode Is Nothing
sFunCode = Right(tNode.Key, Len(tNode.Key) - 1)
Call SaveRight(tNode, sRoleCode, sFunCode)
Set tNode2 = tNode.Child
For i = 1 To tNode.Children
sFunCode = Right(tNode2.Key, Len(tNode2.Key) - 1)
Call SaveRight(tNode2, sRoleCode, sFunCode)
Set tNode2 = tNode2.Next
Next i
Set tNode = tNode.Next
Loop
Unload Me
End Sub
Private Sub SaveRight(ByVal mNode As node, ByVal sRoleCode As String, ByVal sFunCode As String)
Dim sSQL As String
Dim nImg As Long
Dim sEmpower As String
nImg = mNode.Image
If nImg = 2 Then
sEmpower = "1"
ElseIf nImg = 3 Then
sEmpower = "0"
End If
sSQL = "update sysacc set empower='" & sEmpower & "' where rolcode='" & sRoleCode & "' and funcode='" & sFunCode & "'"
Acs_cnt.Execute (sSQL)
End Sub
Private Sub cmdRevokeAll_Click()
Dim i As Integer, tNode As node
If txtCode.Text = "" Then
Exit Sub
End If
If tvwRight.Nodes("r").Children <= 0 Then Exit Sub
Set tNode = tvwRight.Nodes("r").Child
Call SetNodeImage(tNode, 3)
For i = 1 To tvwRight.Nodes("r").Children - 1
Set tNode = tNode.Next
Call SetNodeImage(tNode, 3)
Next i
End Sub
Private Sub Form_Load()
Call Initialize
Call ShowRoles
If lsvRole.ListItems.Count > 0 Then
txtCode.Text = lsvRole.ListItems(1).Text
txtName.Text = lsvRole.ListItems(1).SubItems(1)
Call InitRight(txtCode.Text)
End If
End Sub
Private Sub lsvRole_ItemClick(ByVal Item As MSComctlLib.ListItem)
txtCode.Text = Right(lsvRole.SelectedItem.Key, Len(lsvRole.SelectedItem.Key) - 1)
txtName.Text = lsvRole.SelectedItem.SubItems(1)
Call RefershRight(txtCode.Text)
End Sub
Private Sub tvwright_Expand(ByVal node As MSComctlLib.node)
tvwRight.SelectedItem = node
End Sub
Private Sub tvwright_KeyDown(KeyCode As Integer, Shift As Integer)
Dim nImage As Integer
If KeyCode = vbKeySpace Then
If tvwRight.SelectedItem Is Nothing Then Exit Sub
If tvwRight.SelectedItem.Key = "r" Then Exit Sub
nImage = tvwRight.SelectedItem.Image
If nImage = 2 Then
Call SetNodeImage(tvwRight.SelectedItem, 3)
ElseIf nImage = 3 Then
Call SetNodeImage(tvwRight.SelectedItem, 2)
End If
End If
End Sub
Private Sub tvwright_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 2 Then Exit Sub
If tvwRight.SelectedItem Is Nothing Then Exit Sub
If tvwRight.SelectedItem.Key = "r" Then Exit Sub
Dim nImg As Integer
nImg = tvwRight.SelectedItem.Image
If nImg = 2 Then
Call SetNodeImage(tvwRight.SelectedItem, 3)
ElseIf nImg = 3 Then
Call SetNodeImage(tvwRight.SelectedItem, 2)
End If
End Sub
Private Sub Initialize()
On Error GoTo Fail
With lsvRole
.ColumnHeaders.Add , , "RoleCode", 1000
.ColumnHeaders.Add , , "RoleName", .Width - 1100
.LabelEdit = lvwManual
.FullRowSelect = True
.HideSelection = False
.View = lvwReport
End With
Me.KeyPreview = True
Exit Sub
Fail:
err.Raise err.Number, , err.Description
End Sub
Private Sub ShowRoles()
Dim rstRole As Recordset
Dim cListItem As ListItem
Dim sSQL As String
Dim sRoleCode As String
Dim sRoleName As String
Dim iCount As Long
sSQL = "select * from sysrol where rolcode<>'100' order by rolcode"
Set rstRole = Acs_cnt.Execute(sSQL)
iCount = 1
With rstRole
Do While Not .EOF
Set cListItem = lsvRole.ListItems.Add(iCount, TREEKEY & rstRole!RolCode, rstRole!RolCode)
cListItem.SubItems(1) = rstRole!RolName
iCount = iCount + 1
.MoveNext
Loop
End With
rstRole.Close
Set rstRole = Nothing
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -