Option Compare Database
Option Explicit
Const adhcErrNameNotInCollection = 3265
Const adhcErrAccntAlreadyExists = 3390
Const adhcErrBadPid = 3304
Const adhcErrCantPerformOperation = 3032
Const adhcErrNoPermission = 3033
Const adhcErrBadAccntName = 3030
Const adhcErrBadAccntOrPwd = 3029
Const adhcErrCantPerformAccntOperation = 3109
Function adhcboUsersFill(ctl As Control, varID As Variant, varRow As Variant, varCol As Variant, varCode As Variant) As Variant
Static swrk As Workspace
Static sastrUsr() As String
Static sintUsrCnt As Integer
Dim usr As User
Dim varReturn As Variant
Dim strName As String
Set swrk = DBEngine.Workspaces(0)
Select Case varCode
Case acLBInitialize
sintUsrCnt = 0
swrk.Users.Refresh
ReDim sastrUsr(1 To swrk.Users.count)
For Each usr In swrk.Users
strName = usr.Name
If strName <> "Engine" And strName <> "Creator" And strName <> "Admin" Then
sintUsrCnt = sintUsrCnt + 1
sastrUsr(sintUsrCnt) = strName
End If
Next usr
ReDim Preserve sastrUsr(1 To sintUsrCnt)
varReturn = True
Case acLBOpen
varReturn = Timer
Case acLBGetRowCount
varReturn = sintUsrCnt
Case acLBGetValue
varReturn = sastrUsr(varRow + 1)
End Select
adhcboUsersFill = varReturn
End Function
Private Sub cboUsers_AfterUpdate()
' Disable txtOldPwd if an Admins
' member is changing the password of
' another user since it's unneeded.
If cboUsers = CurrentUser() Then
Me!txtOldPwd.Enabled = True
Else
Me!txtOldPwd.Enabled = False
End If
End Sub
Private Sub cmdClose_Click()
DoCmd.Close
End Sub
Private Sub cmdPwd_Click()
Dim fok As Boolean
Dim ctlOldPwd As TextBox
Dim ctlNewPwd As TextBox
Dim ctlConfirmNewPwd As TextBox
Dim strMsg As String
Set ctlOldPwd = Me!txtOldPwd
Set ctlNewPwd = Me!txtNewPwd
Set ctlConfirmNewPwd = Me!txtConfirmNewPwd
' Perform a binary string comparison of the password
' and the confirmation password.
If StrComp(Nz(ctlNewPwd), Nz(ctlConfirmNewPwd), vbBinaryCompare) = 0 Then
fok = adhSetPwd(strUser:=cboUsers, strOldPwd:=Nz(ctlOldPwd), strNewPwd:=Nz(ctlNewPwd))
If fok Then
strMsg = "Password changed!"
ctlOldPwd = ""
ctlNewPwd = ""
ctlConfirmNewPwd = ""
Else
strMsg = "Password change failed!"
End If
Else
strMsg = "New password entry does not match confirming password entry!"
End If
MsgBox strMsg, vbOKOnly + vbInformation, "Change Password"
End Sub
Private Sub Form_Load()
' If not a member of Admins lock
' and disable the user combo box.
With Me!cboUsers
If Not adhIsGroupMember("Admins") Then
.Locked = True
.Enabled = False
.BackColor = 12632256
Else
.Locked = False
.Enabled = True
.BackColor = 16777215
End If
End With
End Sub
Private Function adhSetPwd(ByVal strUser As String, ByVal strOldPwd As String, ByVal strNewPwd As String) As Boolean
' Sets a new password for user account.
' You must be a member of Admins to set password
' of another user.
'
' In:
' strUser: name of user account
' strOldPwd: existing password; ignored if you
' are a member of Admins and are setting
' password of account other than your own;
' use "" if there is no existing password
' strNewPwd: new password;
' use "" to remove the password
' Out:
' Return Value: True if succeeded; False if failed
' Example:
' fOK = adhSetPwd("Kizzie", "", "Red")
On Error GoTo adhSetPwdErr
Dim wrk As Workspace
Dim usr As User
Dim strMsg As String
Const adhcProcName = "adhSetPwd"
adhSetPwd = False
Set wrk = DBEngine.Workspaces(0)
'Point to user object
Set usr = wrk.Users(strUser)
'Only Admins members can change other users' passwords
'For Admins members, old pwd is ignored
usr.NewPassword strOldPwd, strNewPwd
adhSetPwd = True
adhSetPwdDone:
On Error GoTo 0
Exit Function
adhSetPwdErr:
Select Case Err
Case adhcErrNameNotInCollection
strMsg = "The user account '" & strUser & "' doesn't exist."
Case adhcErrNoPermission
strMsg = "You don't have permission to perform this operation or you have entered the wrong old password."
Case Else
strMsg = "Error " & Err.Number & ": " & Err.Description
End Select
MsgBox strMsg, vbCritical + vbOKOnly, "Password Error!"
Resume adhSetPwdDone
End Function
Private Function adhIsGroupMember(ByVal strGroup As String, Optional ByVal varUser As Variant) As Boolean
' Verifies if a user is a member of a group.
'
' From Access 97 Developer's Handbook
' by Litwin, Getz, and Gilbert. (Sybex)
' Copyright 1997. All Rights Reserved.
'
' In:
' strGroup: name of group
' strUser: optional name of user;
' if missing, current user is used
' Out:
' Return Value: True if user is member; False if not
' Example:
' fOK = adhIsGroupMember("Pets", "Kizzie")
On Error GoTo adhIsGroupMemberErr
Dim wrk As Workspace
Dim usr As User
Dim grp As Group
Dim strMsg As String
Dim intErrHndlrFlag As Integer
Dim varGroupName As Variant
Const adhcFlagSetUser = 1
Const adhcFlagSetGroup = 2
Const adhcFlagCheckMember = 4
Const adhcFlagElse = 0
Const adhcProcName = "adhIsGroupMember"
adhIsGroupMember = False
'Initialize flag for determining
'context for error handler
intErrHndlrFlag = adhcFlagElse
Set wrk = DBEngine.Workspaces(0)
'Refresh users and groups collections
wrk.Users.Refresh
wrk.Groups.Refresh
If IsMissing(varUser) Then varUser = CurrentUser()
intErrHndlrFlag = adhcFlagSetUser
Set usr = wrk.Users(varUser)
intErrHndlrFlag = adhcFlagSetGroup
Set grp = wrk.Groups(strGroup)
intErrHndlrFlag = adhcFlagCheckMember
varGroupName = usr.Groups(strGroup).Name
If Not IsEmpty(varGroupName) Then
adhIsGroupMember = True
End If
adhIsGroupMemberDone:
On Error GoTo 0
Exit Function
adhIsGroupMemberErr:
Select Case Err
Case adhcErrNameNotInCollection
Select Case intErrHndlrFlag
Case adhcFlagSetUser
strMsg = "The user account '" & varUser & "' doesn't exist."
Case adhcFlagSetGroup
strMsg = "The group account '" & strGroup & "' doesn't exist."
Case adhcFlagCheckMember
Resume Next
Case Else
strMsg = "Error " & Err.Number & ": " & Err.Description
End Select
Case adhcErrNoPermission
strMsg = "You don't have permission to perform " & "this operation."
Case Else
strMsg = "Error " & Err.Number & ": " & Err.Description
End Select
MsgBox strMsg, vbCritical + vbOKOnly, "Procedure " & adhcProcName
Resume adhIsGroupMemberDone
End Function
