VBA/Excel/Access/Word/Access/Group Account
Содержание
- 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
<source lang="vb">
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
</source>
Adding a User to a New Group
<source lang="vb">
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
</source>
Add user to group
<source lang="vb">
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
</source>
Creating a Group Account
<source lang="vb">
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
</source>
Creating a Group Account with SQL command
<source lang="vb">
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
</source>
Deleting a Group Account
<source lang="vb">
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
</source>
Deleting a Group Account with SQL command
<source lang="vb">
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
</source>
Deleting a User Account with SQL command
<source lang="vb">
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
</source>
Granting Permissions for Tables to an Existing Group with SQL command
<source lang="vb">
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
</source>
Listing All Group Accounts
<source lang="vb">
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
</source>
Listing Users in Groups
<source lang="vb">
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
</source>
Making a User Account a Member of a Group with SQL command
<source lang="vb">
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
</source>
Removing a User Account from a Group with SQL command
<source lang="vb">
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
</source>
Revoking Security Permissions with SQL command
<source lang="vb">
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
</source>
To create a new group account in the current database
<source lang="vb">
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
</source>