VBA/Excel/Access/Word/Access/Group Account

Материал из VB Эксперт
Версия от 15:46, 26 мая 2010; Admin (обсуждение | вклад) (1 версия)
(разн.) ← Предыдущая | Текущая версия (разн.) | Следующая → (разн.)
Перейти к: навигация, поиск

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>