📄 frmadduserstogroups.frm
字号:
VERSION 5.00
Begin VB.Form frmAddUsersToGroups
Caption = "Add Users to Groups"
ClientHeight = 3420
ClientLeft = 60
ClientTop = 345
ClientWidth = 7965
LinkTopic = "Form1"
ScaleHeight = 3420
ScaleWidth = 7965
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdMove
Caption = ">>"
Height = 435
Index = 3
Left = 3000
TabIndex = 7
Top = 2700
Width = 435
End
Begin VB.CommandButton cmdMove
Caption = ">"
Height = 435
Index = 2
Left = 3000
TabIndex = 6
Top = 2220
Width = 435
End
Begin VB.CommandButton cmdMove
Caption = "<"
Height = 435
Index = 1
Left = 3000
TabIndex = 5
Top = 1740
Width = 435
End
Begin VB.CommandButton cmdMove
Caption = "<<"
Height = 435
Index = 0
Left = 3000
TabIndex = 4
Top = 1260
Width = 435
End
Begin VB.CommandButton cmdClose
Cancel = -1 'True
Caption = "&Close"
Default = -1 'True
Height = 435
Left = 6480
TabIndex = 10
Top = 240
Width = 1395
End
Begin VB.ListBox lstIncludedUsers
Height = 2205
Left = 3660
Sorted = -1 'True
TabIndex = 9
Top = 1080
Width = 2655
End
Begin VB.ListBox lstAvailableUsers
Height = 2205
Left = 120
Sorted = -1 'True
TabIndex = 3
Top = 1080
Width = 2655
End
Begin VB.ComboBox cboGroups
Height = 315
Left = 120
Style = 2 'Dropdown List
TabIndex = 1
Top = 360
Width = 6195
End
Begin VB.Label lblIncludedUsers
Caption = "&Included Users"
Height = 195
Left = 3720
TabIndex = 8
Top = 840
Width = 1155
End
Begin VB.Label lblAvailableUsers
Caption = "&Available Users"
Height = 255
Left = 180
TabIndex = 2
Top = 840
Width = 1215
End
Begin VB.Label lblGroups
Caption = "&Groups"
Height = 255
Left = 180
TabIndex = 0
Top = 120
Width = 2355
End
End
Attribute VB_Name = "frmAddUsersToGroups"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Form_Load()
' if there is an error then goto the code section labeled by ERR_Form_Load
On Error GoTo ERR_Form_Load:
Dim sUserName As String
Dim sPassword As String
' assign default user name and password
sUserName = "Admin"
sPassword = ""
With DBEngine
' set system database path and name
.SystemDB = GetWorkgroupDatabase
' set default user name and password
.DefaultUser = sUserName
.DefaultPassword = sPassword
End With
' popluate the users list box with the available uesrs
FillAvailableUserList
' if there are no valid users, inform the user and exit the application
If (lstAvailableUsers.ListCount < 1) Then
MsgBox "There are no users!", vbExclamation, "USERS"
cmdClose_Click
Else
' populate the group combo box and select the first group automatically
FillGroupCombo
cboGroups.ListIndex = 0
End If
Exit Sub
ERR_Form_Load:
' display error for the user
With Err
MsgBox "ERROR #" & .Number & ": " & .Description, vbExclamation, _
"ERROR"
End With
' end the application
cmdClose_Click
End Sub
Private Sub cboGroups_Click()
' fill the included users text boxes for the selected group
FillIncludedUsers
End Sub
Private Sub cmdMove_Click(Index As Integer)
Dim nCount As Integer
' constant declarations that correspond to the four move buttons on
' the frmAddUsersToGroups form
Const MOVE_REMOVE_ALL = 0
Const MOVE_REMOVE = 1
Const MOVE_ADD = 2
Const MOVE_ALL = 3
Select Case Index
' remove all included users from list
Case MOVE_REMOVE_ALL:
With lstIncludedUsers
For nCount = 0 To .ListCount - 1
RemoveUserFromGroup .List(nCount)
Next nCount
End With
' if a user is selected, remove it
Case MOVE_REMOVE:
With lstIncludedUsers
If (.ListIndex < 0) Then Exit Sub
RemoveUserFromGroup .Text
End With
' if a user is selected, add it
Case MOVE_ADD:
With lstAvailableUsers
If (.ListIndex < 0) Then Exit Sub
AddUserToGroup .Text
End With
' add all users from available users list box
Case MOVE_ALL:
With lstAvailableUsers
For nCount = 0 To .ListCount - 1
AddUserToGroup .List(nCount)
Next nCount
End With
End Select
' repopulated the included user list box
FillIncludedUsers
End Sub
Private Sub cmdClose_Click()
' end the application
Unload Me
End Sub
Private Sub FillGroupCombo()
Dim oGroup As Group
' populate the group combo box with all available groups
For Each oGroup In DBEngine.Workspaces(0).Groups
cboGroups.AddItem oGroup.Name
Next
End Sub
Private Sub FillAvailableUserList()
Dim oUser As User
' populate the user list boxes with all users except CREATOR and ENGINE
For Each oUser In DBEngine.Workspaces(0).Users
With oUser
If (UCase$(.Name) <> "CREATOR") _
And (UCase$(.Name) <> "ENGINE") Then
lstAvailableUsers.AddItem .Name
End If
End With
Next
End Sub
Private Sub FillIncludedUsers()
Dim oUser As User
With lstIncludedUsers
' clear the included users list box
.Clear
' add all the included users for the given group
For Each oUser In _
DBEngine.Workspaces(0).Groups(cboGroups.Text).Users
.AddItem oUser.Name
Next
End With
End Sub
Private Sub AddUserToGroup(sUserName As String)
' if there is an error goto code labeled by ERR_AddUserToGroup
On Error GoTo ERR_AddUserToGroup:
Dim oUser As User
' constant declaration for error when user is already in group
Const ERR_USER_IN_GROUP = 3032
With DBEngine.Workspaces(0).Groups(cboGroups.Text)
' create a user and add him to the group
Set oUser = .CreateUser(sUserName)
.Users.Append oUser
End With
Exit Sub
ERR_AddUserToGroup:
With Err
Select Case .Number
' if user is in group already, continue execution
Case ERR_USER_IN_GROUP:
Resume Next
' unexpected error, notify user
Case Else
MsgBox "ERROR #" & .Number & ": " & .Description, _
vbExclamation, "ERROR"
End Select
End With
End Sub
Private Sub RemoveUserFromGroup(sUserName As String)
' remove user from group
DBEngine.Workspaces(0).Groups(cboGroups.Text).Users.Delete sUserName
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -