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

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