These code samples were posted by MVP Graham Seach in this group
quite a while ago. These should help you build some forms. I will at
some point post some ready made forms for this type of thing, but it
is a bit down on my to-do list at the moment.
Here you go:
'Enumerate all users and groups
Public Sub EnumUsersAndGroups()
Dim wrk As DAO.Workspace
Dim grp As DAO.Group
Dim usr As DAO.User
Set wrk = DBEngine(0)
'Enumerate the groups
Debug.Print "Groups."
For Each grp In wrk.Groups
Debug.Print vbTab & grp.Name
Next grp
'Enumerate the users
Debug.Print "Users."
For Each usr In wrk.Users
Debug.Print vbTab & usr.Name
Next usr
Set grp = Nothing
Set wrk = Nothing
End Sub
'-------
'Enumerate the users belonging to a specific group
Public Sub EnumGroupUsers(strGroup As String)
Dim wrk As DAO.Workspace
Dim varUser As Variant
Set wrk = DBEngine(0)
Debug.Print "Users belonging to the '" & strGroup & "' group..."
For Each varUser In wrk.Groups(strGroup).Users
Debug.Print vbTab & varUser.Name
Next varUser
Set wrk = Nothing
End Sub
'-------
'Enumerate the groups a specific user belongs to
Public Sub EnumUserGroups(strUser As String)
Dim wrk As DAO.Workspace
Dim varGroup As Variant
Set wrk = DBEngine(0)
Debug.Print "Groups to which user '" & strUser & "' belongs..."
For Each varGroup In wrk.Users(strUser).Groups
Debug.Print vbTab & varGroup.Name
Next varGroup
Set wrk = Nothing
End Sub
'-------
'Create a group
Public Sub CreateUserGroup(strGroupName As String, _
strPID As String)
Dim wrk As DAO.Workspace
Dim grp As DAO.Group
Set wrk = DBEngine(0)
On Error GoTo CreateUserGroupErr
'Create the new group
Set grp = wrk.CreateGroup(strGroupName, strPID)
ws.Groups.Append grp
CreateUserGroupErr:
Set grp = Nothing
Set wrk = Nothing
End Sub
'-------
'Delete a group
Public Sub DeleteGroup(strGroup As String)
On Error Resume Next
DBEngine(0).Groups.Delete strGroup
End Sub
'-------
'Create a user
Public Function CreateUserAccount(strUserName As String, _
strPID As String, strPassword As String)
Dim wrk As DAO.Workspace
Dim usr As DAO.User
Set wrk = DBEngine(0)
On Error GoTo CreateUserAccountErr
'Create the new user
Set usr = wrk.CreateUser(strUserName, strPID, strPassword)
wrk.Users.Append usr
CreateUserAccountErr:
Set usr = Nothing
Set wrk = Nothing
End Function
'-------
'Delete a user
Public Sub DeleteUser(strUser As String)
On Error Resume Next
DBEngine(0).Users.Delete strUser
End Sub
'-------
'Add a group to a user
Public Sub AddGroup2User(strUser As String, _
strGroup As String)
Dim wrk As DAO.Workspace
Dim usr As DAO.User
Dim grp As DAO.Group
Set wrk = DBEngine(0)
On Error Resume Next
'Create object references
Set usr = wrk.Users(strUser)
Set grp = usr.CreateGroup(strGroup)
'Add the group to the user's Groups collection
usr.Groups.Append grp
usr.Groups.Refresh
Set usr = Nothing
Set grp = Nothing
Set wrk = Nothing
End Sub
'-------
'Add a user to a group
Public Sub AddUser2Group(strUser As String, _
strGroup As String)
Dim wrk As DAO.Workspace
Dim usr As DAO.User
Dim grp As DAO.Group
Set wrk = DBEngine(0)
On Error Resume Next
'Create object references
Set grp = wrk.Groups(strUser)
Set usr = grp.CreateUser(strUser)
'Add the group to the user's Groups collection
grp.Users.Append usr
grp.Users.Refresh
Set usr = Nothing
Set grp = Nothing
Set wrk = Nothing
End Sub
'-------
'Remove a user from a group
Public Sub DeleteUserFromGroup(strUser As String, _
strGroup As String)
Dim wrk As DAO.Workspace
Set wrk = DBEngine(0)
On Error Resume Next
wrk.Users(strUser).Groups.Delete strGroup
Set wrk = Nothing
End Sub
'-------
'Determine if a user belongs to a specific group
Public Function IsUserInGroup (strUser As String, _
strGroup As String) As Boolean
Dim wrk As DAO.Workspace
Set wrk = DBEngine(0)
On Error Resume Next
IsUserInGroup = False
'Check in the Users --> Groups collection
IsUserInGroup = _
(wrk.Users(strUser).Groups(strGroup).Name = strGroup)
'You can also do it this way...
'Check in the Groups --> Users collection
'IsUserInGroup = _
(wrk.Groups(strGroup).Users(strUser).Name = strUser)
Set wrk = Nothing
End Function
'-------
'Change a user's password
Public Sub ChangePassword(strUser As String, _
strOldPassword As String, strNewPassword As String)
Dim wrk As DAO.Workspace
Dim usr As DAO.User
Set wrk = DBEngine(0)
Set usr = wrk.Users(strUser)
'Change the password
usr.NewPassword strOldPassword, strNewPassword
Set usr = Nothing
Set wrk = Nothing
End Sub
Regards,
Graham R Seach
Microsoft Access MVP
Sydney, Australia[/QUOTE][/QUOTE][/QUOTE]
--
Jeff Conrad
Access Junkie - MVP
http://home.bendbroadband.com/conradsystems/accessjunkie.html
http://www.access.qbuilt.com/html/articles.html
in message:
