Allow Non-Admins to add Workgroup Users 1

[WillYum]

Greetings,

I've spent two days looking for the exact code to do this, but I can't find a perfect fit and I haven't been able to modify the sort-of-fits for my purposes.

Microsoft's User and Group Accounts 'wizard' is just terrible for the 'non-database,need something easier' user types, so I'm working on my own forms to do this. I have the Microsoft provided Add User Code & Change Password Code I got here and both work great BUT I need to allow NON-ADMINS the ability to create user accounts.

How do I let non-Admins Group users add other users to the workgroup file and assign permissions?

-- WillYum

 

[MoLaker]

Below are some old functions that have worked for me in the past. You will have to include an admin user's name and password where the functions read [AdminUserName] & [AdminUserPwd]. Make name & pwd a string by enclosing in quotes ("name" & "pwd"). I believe this also requires DAO added to the application References if you are using Access 2k or later.

Obviously, this greatly reduces your security by including these in a VBA module. This can be addressed in a couple of ways.

1. Make your database front-end a MDE so the code cannot be viewed.
2. Store the new admin user name and password in an encrypted table and retrieve it when needed.

Public Function AddUser(UserName, GroupName, Pwd)
'   Adds user to Workspace and to workgroup Users
    If UserName = [AdminUserName] Then
        MsgBox ("You cannot change this user's account.")
        Exit Function
    End If
    Dim W As Workspace, New_User As User, U As User, G As Group
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    Set New_User = W.CreateUser(UserName, Str(RndNum()), Pwd)
'   Check to make sure group exists
    For Each G In W.Groups
        If G.Name = GroupName Then
            GoTo Cont
        End If
    Next
    MsgBox ("Group [" & GroupName & "] does not exist.  Create group first.")
    Exit Function
Cont:
    On Error Resume Next
    W.Users.Append New_User
    W.Users.refresh
    Set U = W.Groups(GroupName).CreateUser(UserName)
    W.Groups(GroupName).Users.Append U
    W.Groups.refresh
'    MsgBox ("User [" & UserName & "] added to group [" & GroupName & "]")
End Function

Public Function IsGroupCheck(GroupName)
'   returns TRUE if specific Workgroup exists
    Dim W As Workspace, Grp As Group, G As String
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    On Error Resume Next
    IsGroupCheck = False
    For Each Grp In W.Groups
        If Grp.Name = GroupName Then
            IsGroupCheck = True
        End If
    Next
    W.Groups.refresh
End Function

Public Function AddUserToGroup(UserName, GroupName)
'   Adds user to specific Workgrp
    If UserName = [AdminUserName] Then
        MsgBox ("You cannot change this user's account.")
        Exit Function
    End If
    Dim W As Workspace, U As User, usr As User
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    Set U = W.Groups(GroupName).CreateUser(UserName)
    On Error Resume Next
    W.Groups(GroupName).Users.Append U
    W.Groups.refresh
End Function

Public Function UserGroups(UserName)
'   returns list of user group assignments
'   stores groups in array 'Usergrps'
'   and concantenates in function return
    Dim U As User, W As Workspace, Grp As Group
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    On Error Resume Next
    OldGrps = 0
    ReDim UserGrps(0)
    For Each Grp In W.Users(UserName).Groups
        OldGrps = UBound(UserGrps) + 1
        ReDim Preserve UserGrps(OldGrps)
        ' store group names in array
        UserGrps(OldGrps) = Grp.Name
        ' store concantenated group names in string
        UserGroups = UserGroups & Grp.Name & vbCrLf
    Next
    W.Groups.refresh
End Function

Public Function UserGroupCheck(UserName, GroupName) As Boolean
'   returns TRUE if user belongs to specific Workgroup
    Dim W As Workspace, Grp As Group
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    On Error Resume Next
    UserGroupCheck = False
    For Each Grp In W.Users(UserName).Groups
        If Grp.Name = GroupName Then
            UserGroupCheck = True
        End If
    Next
    W.Groups.refresh
    Set W = Nothing
End Function

Public Function RemoveUserFromGroup(UserName, GroupName)
'   Removes user from specific Workgroup
    If UserName = [AdminUserName] Then
        MsgBox ("You cannot change this user's account.")
        Exit Function
    End If
    Dim U As User, W As Workspace, Grp As Group
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    On Error Resume Next
    For Each Grp In W.Users(UserName).Groups
        If Grp.Name = GroupName Then
            W.Groups(GroupName).Users.Delete UserName
            MsgBox ("User [" & UserName & "] removed from group [" & GroupName & "]")
        End If
    Next
    W.Groups.refresh
End Function

Public Function CreateSecurityGroup(GroupName)
'   Creates Workgroup
    Dim W As Workspace
    Dim grpNew As Group
    Dim grpTemp As Group
    Dim prpLoop As property
    Dim usrLoop As User
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    With W
        ' Create and append new group.
        Set grpNew = .CreateGroup(GroupName, Str(RndNum()))
        .Groups.Append grpNew
        MsgBox ("New group [" & GroupName & "] created.")
    End With
End Function

Public Function DeleteSecurityGroup(GroupName)
'   Removes Workgroup
    If GroupName = "admins" Or GroupName = "court" Or GroupName = "users" Then
        MsgBox ("You cannot delete the [" & GroupName & "] group.")
        Exit Function
    End If
    Dim W As Workspace, Grp As Group, msg As String
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    On Error Resume Next
    For Each Grp In W.Groups
        If Grp.Name = GroupName Then
            msg = "Are you sure you want to delete user group " & GroupName & "?"
            If MsgBox(msg, vbYesNo + vbDefaultButton2) = vbYes Then
                W.Groups.Delete (GroupName)
                MsgBox ("Group [" & GroupName & "] deleted.")
            End If
        End If
    Next
    W.Groups.refresh
End Function

Public Function DeleteUser(UserName)
'   Deletes user from Workspace
    If UserName = [AdminUserName] Then
        MsgBox ("You cannot change this user's account.")
        Exit Function
    End If
    Dim W As Workspace
    Set W = DBEngine.CreateWorkspace("TempDeveloperLogin", [AdminUserName], [AdminUserPwd], dbUseJet)
    On Error Resume Next
    W.Users.Delete UserName
    W.Users.refresh
End Function

Function RndNum()
    ' Generate random value between 1111 and 9999.
    ' Required for some included workgroup functions
    RndNum = Int((9999 - 1111 + 1) * Rnd + 1111)
End Function