This may help you get going. It is called from a 'Change password' button on
a form with three fields: OldPassword, NewPassword and VerifyPassword.
The other essential feature is the table UserList which includes USERCODE,
USERNAME, DEPARTMENT, PASSWORDEXPIRES, PASSWORDCHANGED. This is the table
that you need to check when the user enters the database. If the Expiry date
has passed direct them to the change password form instead of the usual menu
so that they can only change their password or leave the database.
John
##################################
Don't Print - Save trees
Function ChangePassword()
Dim CurrentForm As Form, Message As String, SQL As String, ThisUser As User
Dim Security As Recordset
Dim Charset(43) As Integer, ThisAsc As Integer, I As Integer
Dim HasLetter As Boolean, HasNumber As Boolean
On Error GoTo Error_Trap
Set CurrentForm = Screen.ActiveForm
Set ThisUser = DBEngine.Workspaces(0).Users(UCase$(CurrentUser))
HasNumber = False
HasLetter = False
Message = ""
For I = 1 To 26
Charset(I) = 0
Next I
With CurrentForm
If !NewPassword Like "*" & CurrentUser & "*" Then _
Message = "Your User Name cannot be your Password"
If CurrentUser Like "*" & CurrentForm!NewPassword & "*" Then _
Message = "Your User Name cannot be your Password"
If Nz(!VerifyPassword) = "" Or Nz(!NewPassword) = "" Then _
Message = "New Password and Verification must both be entered"
If !VerifyPassword <> !NewPassword Then _
Message = "New Password and Verification must be the same"
If !OldPassword = !NewPassword Then _
Message = "New Password must be different from Old Password"
If Len(Nz(!NewPassword)) < 5 Then _
Message = "New Password must be at least five characters"
For I = 1 To Len(Nz(!NewPassword))
ThisAsc = Asc(UCase$(Mid$(!NewPassword, I, 1))) - 47
If ThisAsc < 18 Then HasNumber = True
If ThisAsc > 17 Then HasLetter = True
Charset(ThisAsc) = Charset(ThisAsc) + 1
If Charset(ThisAsc) > 2 Then Message = "Too many letter repeats"
Next I
If Not HasNumber Then _
Message = Message & vbCrLf & "Password must be Alphanumberic"
If Not HasLetter Then _
Message = Message & vbCrLf & "Password must include letters"
SQL = "SELECT count(*) AS RowCount FROM UserList WHERE UserCode = '" _
& UCase$(CurrentUser) & "'" & " AND (UserName LIKE '*" & !NewPassword _
& "*' OR '" & !NewPassword & "' LIKE '*' & UserName & '*')"
End With
Set Security = CurrentDb.OpenRecordset(SQL, DB_OPEN_SNAPSHOT)
If Security!RowCount > 0 Then Message = "Your Name cannot be your Password"
Security.Close
CheckChangePassword:
If Message = "" Then
ThisUser.NewPassword Nz(CurrentForm!OldPassword), CurrentForm!NewPassword
SQL = "UPDATE UserList SET PasswordChanged = #" & FormatDate(SysTime) _
& "#," & " PasswordExpires = #" & FormatDate(DateAdd("d", 90, SysTime))
& "#" _
& " WHERE UserCode = '" & UCase$(CurrentUser) & "'"
CurrentDb.Execute SQL, dbFailOnError
msgbox "Password Changed Successfully", vbInformation
FormClose
DatabaseOpen "A" ' This function opens the database normally.
Else
msgbox Message & CR() & "Password NOT changed", vbCritical, "Invalid Input"
End If
Exit_Sub:
Set Security = Nothing
Set CurrentForm = Nothing
Set ThisUser = Nothing
Exit Function
Error_Trap:
If Err = 3033 Then
Message = "Old Password Incorrect"
Else
Message = "Change password Error - " & GetDAOErrors & Error$
End If
Resume CheckChangePassword
End Function