frmallset.frm
来自「OA编程 源代码」· FRM 代码 · 共 1,598 行 · 第 1/4 页
FRM
1,598 行
Height = 1200
Left = 2220
Picture = "frmAllSet.frx":2680
Top = 120
Width = 690
End
Begin VB.Line Line2
BorderColor = &H00C0FFFF&
X1 = 120
X2 = 3000
Y1 = 1350
Y2 = 1350
End
Begin VB.Label Label3
AutoSize = -1 'True
BackColor = &H00800000&
BackStyle = 0 'Transparent
Caption = "单用户"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 195
Left = 990
TabIndex = 5
Top = 660
Width = 585
End
Begin VB.Label Label4
AutoSize = -1 'True
BackColor = &H00800000&
BackStyle = 0 'Transparent
Caption = "用户组"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 195
Left = 990
TabIndex = 4
Top = 1050
Width = 585
End
Begin VB.Image Image1
Height = 255
Left = 660
Picture = "frmAllSet.frx":30A1
Top = 600
Width = 255
End
Begin VB.Image Image2
Height = 240
Left = 660
Picture = "frmAllSet.frx":3145
Top = 1020
Width = 240
End
Begin VB.Label Label6
BackColor = &H00800000&
BackStyle = 0 'Transparent
Caption = $"frmAllSet.frx":320F
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 1395
Left = 150
TabIndex = 3
Top = 1500
Width = 3015
End
Begin VB.Label Label7
AutoSize = -1 'True
BackColor = &H00800000&
BackStyle = 0 'Transparent
Caption = "系统提示您"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 180
Left = 90
TabIndex = 2
Top = 120
Width = 900
End
End
End
End
Attribute VB_Name = "FrmAllSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private PubAllSetConn As New ADODB.Connection
Private PubAllSetRst As New ADODB.Recordset
Private TempItem As MSComctlLib.ListItem
Private Rsttemp As New ADODB.Recordset
Private Jishu As Integer
Private BTreeViewExpand As Boolean
Private CurrentLanMu As String '当前栏目编号
Private CurrentUserOrGroup As String '当前用户或用户组名称
Private Const InitFontColor = &HFF8080
Private Const SelectColor = &HFFFF&
Private Sub CmdAddOrRemove_Click(Index As Integer)
Dim i, w, c As Integer
Dim OldKey As String
Dim OldIco As Integer
Dim OldText As String
w = 0
Select Case Index
Case 0
If LstSour.SelCount <> 0 Then
For i = 0 To LstSour.ListCount - 1
If LstSour.Selected(i) Then
LstTar.AddItem LstSour.list(i)
LstTar.ItemData(LstTar.ListCount - 1) = LstSour.ItemData(i)
End If
Next i
For i = 1 To LstSour.SelCount
For c = 0 To LstSour.ListCount - 1
If LstSour.Selected(c) Then
LstSour.RemoveItem c
Exit For
End If
Next c
Next i
End If
Case 1
If LstTar.SelCount <> 0 Then
For i = 0 To LstTar.ListCount - 1
If LstTar.Selected(i) Then
LstSour.AddItem LstTar.list(i)
LstSour.ItemData(LstSour.ListCount - 1) = LstTar.ItemData(i)
End If
Next i
For i = 1 To LstTar.SelCount
For c = 0 To LstTar.ListCount - 1
If LstTar.Selected(c) Then
LstTar.RemoveItem c
Exit For
End If
Next c
Next i
End If
Case 2
For i = 1 To LstViewSour.ListItems.Count
If LstViewSour.ListItems(i).Selected Then
w = w + 1
OldKey = LstViewSour.ListItems(i).Key
OldIco = LstViewSour.ListItems(i).Icon
OldText = LstViewSour.ListItems(i).Text
Set TempItem = LstViewTar.ListItems.Add(, OldKey, OldText, OldIco)
End If
Next i
If w = 0 Then
Exit Sub
End If
For i = 1 To w
For c = 1 To LstViewSour.ListItems.Count
If LstViewSour.ListItems(c).Selected Then
LstViewSour.ListItems.Remove c
Exit For
End If
Next c
Next i
Case 3
For i = 1 To LstViewTar.ListItems.Count
If LstViewTar.ListItems(i).Selected Then
w = w + 1
OldKey = LstViewTar.ListItems(i).Key
OldIco = LstViewTar.ListItems(i).Icon
OldText = LstViewTar.ListItems(i).Text
Set TempItem = LstViewSour.ListItems.Add(, OldKey, OldText, OldIco)
End If
Next i
If w = 0 Then
Exit Sub
End If
For i = 1 To w
For c = 1 To LstViewTar.ListItems.Count
If LstViewTar.ListItems(c).Selected Then
LstViewTar.ListItems.Remove c
Exit For
End If
Next c
Next i
End Select
End Sub
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Sub CmdSave_Click()
Dim i, w, c As Integer
Dim UserType As Integer
Dim Username As String
Dim Sqlstring As String
Dim Myarray(1000) As String
Dim MyarrayNum As Integer
Dim MyBoolean As Boolean
If LstTar.ListCount < 1 Then
MsgBox "您没有选种相应的栏目！", 64, "提示"
Exit Sub
End If
If LstViewTar.ListItems.Count < 1 Then
MsgBox "您需要选择用户或用户组！", 64, "提示"
Exit Sub
End If
CmdSave.Enabled = False
Me.MousePointer = 13
MyarrayNum = 0
'将对应的用户组影射成用户名
For i = 1 To LstViewTar.ListItems.Count
If Mid(LstViewTar.ListItems(i).Key, 3, 1) = "." Then
'获得用户类型,0为用户组，1为用户,
UserType = 1
Username = Right(LstViewTar.ListItems(i).Key, Len(LstViewTar.ListItems(i).Key) - 3)
For c = 0 To LstTar.ListCount - 1
MyBoolean = SetLimit(UserType, Username, LstTar.ItemData(c))
If Not MyBoolean Then
MsgBox "权限设置错误！请检查！", 64, "提示"
Exit Sub
End If
Next c
Else
UserType = 0
GroupName = Right(LstViewTar.ListItems(i).Key, Len(LstViewTar.ListItems(i).Key) - 4)
For c = 0 To LstTar.ListCount - 1
MyBoolean = SetLimit(UserType, (GroupName), LstTar.ItemData(c))
Next c
End If
Next i
'判断集合中是否存在此用户,如果存在，那么下一个
' Select Case UserType
' '用户组
' Case 0
' SqlString = "select username from groupuser where groupname='" & groupname & "'"
' Set RstTemp = PubAllSetConn.Execute(SqlString)
' Do While Not RstTemp.EOF
' If MyarrayNum = 0 Then
' Myarray(0) = RstTemp(0)
' MyarrayNum = MyarrayNum + 1
' Else
' For c = 0 To MyarrayNum
' If Myarray(c) = RstTemp(0) Then
' Exit For
' ElseIf c = MyarrayNum Then
'
' Myarray(MyarrayNum) = RstTemp(0)
' MyarrayNum = MyarrayNum + 1
' End If
' Next c
' End If
' RstTemp.MoveNext
' Loop
' '用户名
' Case 1
' If MyarrayNum = 0 Then
' Myarray(0) = UserName
' MyarrayNum = MyarrayNum + 1
' Else
' For c = 0 To MyarrayNum
' If Myarray(c) = UserName Then
' Exit For
' ElseIf c = MyarrayNum Then
'
' Myarray(MyarrayNum) = UserName
' MyarrayNum = MyarrayNum + 1
' End If
' Next c
' End If
'
' End Select
'Next i
''得到所有用户
'
'For i = 0 To MyarrayNum - 1
' For c = 0 To LstTar.ListCount - 1
' MyBoolean = SetLimit(Myarray(i), LstTar.ItemData(c), CurrentLimit)
' If Not MyBoolean Then
' MsgBox "权限设置错误！请检查！", 64, "提示"
' Exit Sub
' End If
'
'
'
' Next c
CmdSave.Enabled = True
Me.MousePointer = 1
Timer1.Enabled = True
End Sub
Private Sub Command1_Click()
ListView1.ListItems.Add , , "adsfasdf", 3
End Sub
Private Sub Command2_Click()
ListView1.View = lvwList
End Sub
Private Sub Form_Load()
Dim Sqlstring As String
'设置窗体位置
Me.Left = 0
Me.Top = 0
Timer1.Interval = 400
Timer1.Enabled = False
'设置SSTAB的默认项目
'STabMenu.TabPicture(0) = LoadPicture(App.Path & "\image\label16.gif")
STabMenu.Tab = 0
'设置连接
On Error Resume Next
PubAllSetConn.ConnectionString = Pubsaconnstring
PubAllSetConn.Open
'取出所有根栏目
Sqlstring = "select treeno,treename from treebase order by treeno"
Set PubAllSetRst = PubAllSetConn.Execute(Sqlstring)
Do While Not PubAllSetRst.EOF
If Len(Trim(PubAllSetRst(0))) = 2 Then
LstSour.AddItem PubAllSetRst(1)
LstSour.ItemData(LstSour.ListCount - 1) = PubAllSetRst(0)
End If
PubAllSetRst.MoveNext
Loop
PubAllSetRst.Close
'取出所有用户以及用户组
Sqlstring = "select distinct groupname from groupuser where groupname<>''"
Set PubAllSetRst = PubAllSetConn.Execute(Sqlstring)
Do While Not PubAllSetRst.EOF
Set TempItem = LstViewSour.ListItems.Add(, "用户组." & PubAllSetRst(0), PubAllSetRst(0), 2)
PubAllSetRst.MoveNext
Loop
PubAllSetRst.Close
Sqlstring = "select groupname,username,username_c from groupuser "
Set PubAllSetRst = PubAllSetConn.Execute(Sqlstring)
Do While Not PubAllSetRst.EOF
If Trim(PubAllSetRst(0)) = "" Then
Set TempItem = LstViewSour.ListItems.Add(, "用户." & PubAllSetRst(1), PubAllSetRst(2), 1)
End If
PubAllSetRst.MoveNext
Loop
PubAllSetRst.Close
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?