Sending an e-mail to users whose password is about to expire
Originally published September 13, 2005
(Note November 13, 2007: My second most popular blog post ever. Also due for some cleanup and re-write.)
This has come up a number of times, and I actually thought I'd blogged about it in the past -- but I guess not.
If you have users that only use POP and/or IMAP, and never log into via Outlook/Exchange or OWA Premium, then those users do not get notified when their password is about to expire.
You can write a script that sends your users e-mail when their passwords are about to expire. The script below is based on a Scripting Clinic article available here, with some bug fixes and enhancements.
This script, with a few changes and enhancements, is also in my upcoming book from O'Reilly: “Essential Exchange Server 2003“.
'
' exch-pwd-expires.vbs
'
' Michael B. Smith
' March 21, 2005
'
' This program scans all users in the Users container and all organizational units
' beneath the HOSTING_OU organizational unit, for users whose passwords have either
' already expired or will expire within DAYS_FOR_EMAIL days.
'
' An email is sent, using CDO, via the SMTP server specified as SMTP_SERVER to the
' user to tell them to change their password. You should change strFrom to match
' the email address of the administrator responsible for password changes.
'
' You will, at a minimum, need to change the SMTP_SERVER, the HOSTING_OU, and the
' STRFROM constants. If you run this on an Exchange server, then SMTP_SERVER can
' be "127.0.0.1" - and it may be either an ip address or a resolvable name.
'
' If you don't have an OU containing sub-OU's to scan, then set HOSTING_OU to the
' empty string ("").
'
Option Explicit
' Per environment constants - you should change these!
Const HOSTING_OU = "Hosting"
Const SMTP_SERVER = "127.0.0.1"
Const STRFROM = "emailadmin@your.domain"
Const DAYS_FOR_EMAIL = 15
' System Constants - do not change
Const ONE_HUNDRED_NANOSECOND = .000000100 ' .000000100 is equal to 10^-7
Const SECONDS_IN_DAY = 86400
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
' Change to "True" for extensive debugging output
Const bDebug = False
Dim objRoot
Dim numDays, iResult
Dim strDomainDN
Dim objContainer, objSub
Set objRoot = GetObject ("LDAP://RootDSE")
strDomainDN = objRoot.Get ("defaultNamingContext")
Set objRoot = Nothing
numdays = GetMaximumPasswordAge (strDomainDN)
dp "Maximum Password Age: " & numDays
If numDays > 0 Then
Set objContainer = GetObject ("LDAP://CN=Users," & strDomainDN)
Call ProcessFolder (objContainer, numDays)
Set objContainer = Nothing
If Len (HOSTING_OU) > 0 Then
Set objContainer = GetObject ("LDAP://OU=" & HOSTING_OU & "," & strDomainDN)
For each objSub in objContainer
Call ProcessFolder (objSub, numDays)
Next
Set objContainer = Nothing
End If
'========================================
' Add the number of days to the last time
' the password was set.
'========================================
'whenPasswordExpires = DateAdd ("d", numDays, oUser.PasswordLastChanged)
'WScript.Echo "Password Last Changed: " & oUser.PasswordLastChanged
'WScript.Echo "Password Expires On: " & whenPasswordExpires
End If
WScript.Echo "Done"
Function GetMaximumPasswordAge (ByVal strDomainDN)
Dim objDomain, objMaxPwdAge
Dim dblMaxPwdNano, dblMaxPwdSecs, dblMaxPwdDays
Set objDomain = GetObject("LDAP://" & strDomainDN)
Set objMaxPWdAge = objDomain.maxPwdAge
If objMaxPwdAge.LowPart = 0 And objMaxPwdAge.Highpart = 0 Then
' Maximum password age is set to 0 in the domain
' Therefore, passwords do not expire
GetMaximumPasswordAge = 0
Else
dblMaxPwdNano = Abs (objMaxPwdAge.HighPart * 2^32 + objMaxPwdAge.LowPart)
dblMaxPwdSecs = dblMaxPwdNano * ONE_HUNDRED_NANOSECOND
dblMaxPwdDays = Int (dblMaxPwdSecs / SECONDS_IN_DAY)
GetMaximumPasswordAge = dblMaxPwdDays
End If
End Function
Function UserIsExpired (objUser, iMaxAge, iDaysForEmail, iRes)
Dim intUserAccountControl, dtmValue, intTimeInterval
Dim strName
On Error Resume Next
Err.Clear
strName = Mid (objUser.Name, 4)
intUserAccountControl = objUser.Get ("userAccountControl")
If intUserAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then
dp "The password for " & strName & " does not expire."
UserIsExpired = False
Else
iRes = 0
dtmValue = objUser.PasswordLastChanged
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
UserIsExpired = True
dp "The password for " & strName & " has never been set."
Else
intTimeInterval = Int (Now - dtmValue)
dp "The password for " & strName & " was last set on " & _
DateValue(dtmValue) & " at " & TimeValue(dtmValue) & _
" (" & intTimeInterval & " days ago)"
If intTimeInterval >= iMaxAge Then
dp "The password for " & strName & " has expired."
UserIsExpired = True
Else
iRes = Int ((dtmValue + iMaxAge) - Now)
dp "The password for " & strName & " will expire on " & _
DateValue(dtmValue + iMaxAge) & " (" & _
iRes & " days from today)."
If iRes <= iDaysForEmail Then
dp strName & " needs an email for password change"
UserIsExpired = True
Else
dp strName & " does not need an email for password change"
UserIsExpired = False
End If
End If
End If
End If
End Function
Sub ProcessFolder (objContainer, iMaxPwdAge)
Dim objUser, iResult
objContainer.Filter = Array ("User")
Wscript.Echo "Checking company = " & Mid (objContainer.Name, 4)
For each objUser in objContainer
If Right (objUser.Name, 1) <> "$" Then
If IsEmpty (objUser.Mail) or IsNull (objUser.Mail) Then
dp Mid (objUser.Name, 4) & " has no mailbox"
Else
If UserIsExpired (objUser, iMaxPwdAge, DAYS_FOR_EMAIL, iResult) Then
wscript.Echo "...sending an email for " & objUser.Mail
Call SendEmail (objUser, iResult)
Else
dp "...don't send an email"
End If
End If
End If
Next
End Sub
Sub SendEmail (objUser, iResult)
Dim objMail
Set objMail = CreateObject ("CDO.Message")
objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_SERVER
objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMail.Configuration.Fields.Update
objMail.From = STRFROM
objMail.To = objUser.Mail
objMail.Subject = "Password needs to be set for " & Mid (objUser.Name, 4)
objMail.Textbody = "The active directory password for user " & objUser.userPrincipalName & _
" (" & objUser.sAMAccountName & ")" & vbCRLF & _
"will expire in " & iResult & " days. " & vbCRLF & _
"Please change it as soon as possible." & vbCRLF & vbCRLF & _
"Thank you," & vbCRLF & _
"Your email administrator"
objMail.Send
Set objMail = Nothing
End Sub
Sub dp (str)
If bDebug Then
WScript.Echo str
End If
End Sub
----- edit on August 5, 2010 -----
Common issues:
[1] if you want to use scan an OU that is below the top level of the domain, you need to be careful about how you format your HOSTING_OU replacement. For example, if your domain is "example.local", and you want to scan the OU named "SubOU" which is beneath the top-level OU named "TopOU", you would need to:
Const HOSTING_OU = "SubOU,OU=TopOU"
this be because of the way HOSTING_OU is parsed. Yes, it looks a little weird, but it works. Trust me. :-)
[2] Secondly, if you have users in HOSTING_OU and not just other OUs, then you need to make a small code change. Find this code:
If Len (HOSTING_OU) > 0 Then
Set objContainer = GetObject ("LDAP://OU=" & HOSTING_OU & "," & strDomainDN)
For each objSub in objContainer
Call ProcessFolder (objSub, numDays)
Next
Set objContainer = Nothing
End If
Change it to
If Len (HOSTING_OU) > 0 Then
Set objContainer = GetObject ("LDAP://OU=" & HOSTING_OU & "," & strDomainDN)
Call ProcessFolder (objContainer, numDays) ''' add this line – that’s the only change
For each objSub in objContainer
Call ProcessFolder (objSub, numDays)
Next
Set objContainer = Nothing
End If
Notice that there is only a single additional line added. This is arguably a bug. :-)
[3] I really need to rewrite this in PowerShell. It's so much easier! :-)