VBA/Excel/Access/Word/Access/Group Account — различия между версиями
Admin (обсуждение | вклад) м (1 версия) |
Admin (обсуждение | вклад) м (1 версия) |
(нет различий)
|
Текущая версия на 12:46, 26 мая 2010
Содержание
- 1 Add group
- 2 Adding a User to a New Group
- 3 Add user to group
- 4 Creating a Group Account
- 5 Creating a Group Account with SQL command
- 6 Deleting a Group Account
- 7 Deleting a Group Account with SQL command
- 8 Deleting a User Account with SQL command
- 9 Granting Permissions for Tables to an Existing Group with SQL command
- 10 Listing All Group Accounts
- 11 Listing Users in Groups
- 12 Making a User Account a Member of a Group with SQL command
- 13 Removing a User Account from a Group with SQL command
- 14 Revoking Security Permissions with SQL command
- 15 To create a new group account in the current database
Add group
Sub GroupAdd()
Dim mySpace As Workspace
Dim grpRegistrars As Group
Dim strGroupPID As String
Set mySpace = DBEngine(0)
strGroupPID = "5678"
Set grpRegistrars = mySpace.CreateGroup("Registrars")
grpRegistrars.PID = strGroupPID
mySpace.Groups.Append grpRegistrars
End Sub
Adding a User to a New Group
Sub AddUser_ToNewGroup()
Dim cat As ADOX.Catalog
Dim conn As ADODB.Connection
Dim strDB As String
Dim strSysDb As String
Dim strName As String
On Error GoTo ErrorHandle
strDB = CurrentProject.Path & "\mydb.mdb"
strSysDb = CurrentProject.Path & "\mydb.mdw"
strName = "Elite"
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Jet OLEDB:System Database") = strSysDb
.Properties("User ID") = "Developer"
.Properties("Password") = "mypass"
.Open strDB
End With
Set cat = New ADOX.Catalog
With cat
.ActiveConnection = conn
.Groups.Append strName
.Users("PowerUser").Groups.Append strName
End With
ExitHere:
Set cat = Nothing
conn.Close
Set conn = Nothing
Exit Sub
ErrorHandle:
Set cat = Nothing
If Err.Number = -2147467259 Then
MsgBox strName & " account already exists."
Else
MsgBox Err.Description
End If
Resume ExitHere
End Sub
Add user to group
Sub AddUserToGroup()
Dim mySpace As Workspace
Dim usrMark As User
Set mySpace = DBEngine(0)
Set usrMark = mySpace.CreateUser("Mark Fenton")
mySpace.Groups("Registrars").Users.Append usrMark
End Sub
Creating a Group Account
Sub Create_Group()
Dim cat As ADOX.Catalog
Dim conn As ADODB.Connection
Dim strDB As String
Dim strSysDb As String
Dim strName As String
On Error GoTo ErrorHandle
strDB = CurrentProject.Path & "\mydb.mdb"
strSysDb = CurrentProject.Path & "\mydb.mdw"
strName = "Masters"
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Jet OLEDB:System Database") = strSysDb
.Properties("User ID") = "Developer"
.Properties("Password") = "pass"
.Open strDB
End With
Set cat = New ADOX.Catalog
With cat
.ActiveConnection = conn
.Groups.Append strName
End With
Debug.Print "Successfully created " & strName & " group account."
ExitHere:
Set cat = Nothing
conn.Close
Set conn = Nothing
Exit Sub
ErrorHandle:
If Err.Number = -2147467259 Then
MsgBox strName & " group already exists."
Else
MsgBox Err.Description
End If
End Sub
Creating a Group Account with SQL command
Sub CreateGroupAccount()
Dim conn As ADODB.Connection
On Error GoTo ErrorHandler
Set conn = CurrentProject.Connection
conn.Execute "CREATE GROUP YourGroupN asdf"
ExitHere:
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
End If
Set conn = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ":" & Err.Description
Resume ExitHere
End Sub
Deleting a Group Account
Sub Delete_Group()
Dim conn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim strDB As String
Dim strSysDb As String
On Error GoTo ErrorHandle
strDB = CurrentProject.Path & "\mydb.mdb"
strSysDb = CurrentProject.Path & "\mydb.mdw"
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Jet OLEDB:System Database") = strSysDb
.Properties("User ID") = "Developer"
.Properties("Password") = "mypass"
.Open strDB
End With
Set cat = New ADOX.Catalog
With cat
.ActiveConnection = conn
.Groups.Delete "GroupName"
End With
ExitHere:
Set cat = Nothing
conn.Close
Set conn = Nothing
Exit Sub
ErrorHandle:
If Err.Number = 3265 Then
cat.Groups.Append "Masters"
Resume
Else
MsgBox Err.Description
Resume ExitHere
End If
End Sub
Deleting a Group Account with SQL command
Sub DeleteGroupAccount()
Dim conn As ADODB.Connection
On Error GoTo ErrorHandler
Set conn = CurrentProject.Connection
conn.Execute "DROP GROUP YourGroupName"
ExitHere:
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
End If
Set conn = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ":" & Err.Description
Resume ExitHere
End Sub
Deleting a User Account with SQL command
Sub DeleteUserAccount()
Dim conn As ADODB.Connection
On Error GoTo ErrorHandler
Set conn = CurrentProject.Connection
conn.Execute "DROP USER yourName"
ExitHere:
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
End If
Set conn = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ":" & Err.Description
Resume ExitHere
End Sub
Granting Permissions for Tables to an Existing Group with SQL command
Sub SetTblPermissions()
Dim conn As ADODB.Connection
On Error GoTo ErrorHandler
Set conn = CurrentProject.Connection
conn.Execute "GRANT SELECT, DELETE, INSERT, " _
& "UPDATE ON CONTAINER TABLES TO yourGroupName"
ExitHere:
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
End If
Set conn = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ":" & Err.Description
Resume ExitHere
End Sub
Listing All Group Accounts
Sub List_Groups()
Dim conn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim grp As New ADOX.Group
Dim strDB As String
Dim strSysDb As String
strDB = CurrentProject.Path & "\mydb.mdb"
strSysDb = CurrentProject.Path & "\mydb.mdw"
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Jet OLEDB:System Database") = strSysDb
.Properties("User ID") = "Developer"
.Properties("Password") = "mypass"
.Open strDB
End With
Set cat = New ADOX.Catalog
cat.ActiveConnection = conn
For Each grp In cat.Groups
Debug.Print grp.Name
Next
Set cat = Nothing
conn.Close
Set conn = Nothing
End Sub
Listing Users in Groups
Sub List_UsersInGroups()
Dim conn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim grp As New ADOX.Group
Dim myUser As New ADOX.User
Dim strDB As String
Dim strSysDb As String
strDB = CurrentProject.Path & "\mydb.mdb"
strSysDb = CurrentProject.Path & "\mydb.mdw"
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Jet OLEDB:System Database") = strSysDb
.Properties("User ID") = "Developer"
.Properties("Password") = "mypass"
.Open strDB
End With
Set cat = New ADOX.Catalog
cat.ActiveConnection = conn
For Each grp In cat.Groups
Debug.Print "Group Name: " & grp.Name
If cat.Groups(grp.Name).Users.count = 0 Then
Debug.Print "There are no users in the " & grp & " group."
End If
For Each myUser In cat.Groups(grp.Name).Users
Debug.Print "User Name: " & myUser.Name
Next myUser
Next grp
Set cat = Nothing
conn.Close
Set conn = Nothing
End Sub
Making a User Account a Member of a Group with SQL command
Sub AddUserToGroup()
Dim conn As ADODB.Connection
On Error GoTo ErrorHandler
Set conn = CurrentProject.Connection
conn.Execute "ADD USER YourName TO YourGroupN"
ExitHere:
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
End If
Set conn = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ":" & Err.Description
Resume ExitHere
End Sub
Removing a User Account from a Group with SQL command
Sub RemoveUserFromGroup()
Dim conn As ADODB.Connection
On Error GoTo ErrorHandler
Set conn = CurrentProject.Connection
conn.Execute "DROP USER yourName FROM YourGroupName"
ExitHere:
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
End If
Set conn = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ":" & Err.Description
Resume ExitHere
End Sub
Revoking Security Permissions with SQL command
Sub RevokePermission()
Dim conn As ADODB.Connection
On Error GoTo ErrorHandler
Set conn = CurrentProject.Connection
conn.Execute "REVOKE DELETE ON CONTAINER TABLES FROM YourGroupName"
ExitHere:
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
End If
Set conn = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ":" & Err.Description
Resume ExitHere
End Sub
To create a new group account in the current database
Sub Create_Group2()
Dim cat As ADOX.Catalog
On Error GoTo ErrorHandle
Set cat = New ADOX.Catalog
With cat
.ActiveConnection = CurrentProject.Connection
.Groups.Append "Masters"
End With
ExitHere:
Set cat = Nothing
Exit Sub
ErrorHandle:
If Err.Number = -2147467259 Then
MsgBox "This group already exists."
Else
MsgBox Err.Description
End If
Resume ExitHere
End Sub