Here is a script that you can run daily on your DC to send an email to users from an OU, everyday for some days before it expires.
So they know they have to change it before it really expires.
Option Explicit
' Per environment constants - you should change these
Const SMTP_SERVER = "emailserv.mydomain.intra" ' your mail server
Const STRFROM = "dcserv@mydomain.intra" ' your DC
Const DAYS_FOR_EMAIL = 14 'Send notification when pwd will expire in this number of days
Const GROUPDN = "CN=USERS_OU,OU=Groups,OU=Domain Users,DC=mydomain,DC=intra" ' Recurse this user OU
Const LOGFILE = "C:\Scripts\PasswordExpiration\passwordexpiration.log" ' Log file path
' 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 numDays, iResult
Dim strDomain
Dim objGroup, objMember, member
Dim objFSO, objFile, strOutput
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(LOGFILE) = True Then
objFSO.DeleteFile(LOGFILE)
End If
Set objFile = objFSO.OpenTextFile(LOGFILE, 8, True)
Set objGroup = GetObject("LDAP://" & GROUPDN)
objFile.WriteLine "Executed at " & Now() & vbCRLF
objFile.WriteLine "Enumerating members of " & objGroup.distinguishedName & ":" & vbCRLF
Call GetSubMembers(objGroup)
objFile.WriteLine "Done. Finished at " & Now() & "."
objFile.Close
Function GetSubMembers (GroupObject)
Dim TmpMember
numDays = 0
If (TypeName(GroupObject.Member) = "Empty") Then
Exit Function
End If
If (TypeName(GroupObject.Member) = "String") Then
TmpMember = GroupObject.Member
Set objMember = GetObject("LDAP://" & GroupObject.Member)
If (LCase(objMember.Class) = "user") then
Wscript.Echo objMember.sAMAccountName
strDomain = Mid(objMember.distinguishedname, InStr(objMember.distinguishedname, "DC="))
numdays = GetMaximumPasswordAge (strDomain)
objFile.WriteLine objMember.sAMAccountName & " " & TmpMember & " " & numdays & " " & objMember.Mail
Call ProcessUser (numDays)
else
Wscript.Echo "Group : " & objMember.CN
objFile.WriteLine "Group 1: " & objMember.CN
Call GetSubMembers(objMember)
End If
Else
For Each TmpMember In GroupObject.Member
Set objMember = GetObject("LDAP://" & TmpMember)
If (LCase(objMember.Class) = "group") Then
Wscript.Echo "Group : " & objMember.CN
objFile.WriteLine "Group 2: " & objMember.CN
Call GetSubMembers(objMember)
Else
Wscript.Echo objMember.sAMAccountName
strDomain = Mid(objMember.distinguishedname, InStr(objMember.distinguishedname, "DC="))
numdays = GetMaximumPasswordAge (strDomain)
objFile.WriteLine objMember.sAMAccountName & " " & TmpMember & " " & numdays & " " & objMember.Mail
Call ProcessUser (numDays)
End If
Next
End If
End Function
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 (objMember, iMaxAge, iDaysForEmail, iRes)
Dim intUserAccountControl, dtmValue, intTimeInterval
Dim strName
On Error Resume Next
Err.Clear
strName = Mid (objMember.Name, 4)
intUserAccountControl = objMember.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 = objMember.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"
'Swap commented variable below to force email to be sent (for testing).
UserIsExpired = False
End If
End If
End If
End If
End Function
Sub ProcessUser (iMaxPwdAge)
Dim iResult, strExpire
If Right (objMember.Name, 1) <> "$" Then
If IsEmpty (objMember.Mail) or IsNull (objMember.Mail) Then
dp Mid (objMember.Name, 4) & " has no mailbox"
Else
If UserIsExpired (objMember, iMaxPwdAge, DAYS_FOR_EMAIL, iResult) Then
objFile.WriteLine "Sending an email to " & objMember.givenName & " " & objMember.sn & _
" (" & objMember.Mail & "). Password expires in " & iResult & " days." & vbCRLF
Call SendEmail (iResult)
Else
If iResult = "" Then
strExpire = "."
Else
strExpire = " for " & iResult & " days."
End If
objFile.WriteLine "Skipping " & objMember.givenName & " " & objMember.sn & _
". Password does not expire" & strExpire & vbCRLF
End If
End If
End If
End Sub
Sub SendEmail (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 = objMember.Mail
objMail.Subject = "[IMPORTANT] :: The Windows password of " & Mid (objMember.Name, 4) & " is going to expire"
objMail.Textbody = "Hello, The Windows Active Directory password for user " & objMember.givenName & " " & objMember.sn & _
" (" & objMember.sAMAccountName & ")" & " will expire in " & iResult & " days. " & vbCRLF & vbCRLF & _
"Please change it before it expires (CTRL+ALT+DEL, then change password)." & vbCRLF & vbCRLF & _
"If you are a remote user, please connect with your VPN client and then change the password (so that DC server will be notified). The VPN peer will be automatically updated within 5 minutes." & vbCRLF & _
"You can also use Outlook Web Access with Internet Explorer (richer GUI than in Firefox) from outside to change it before it expires." & vbCRLF & vbCRLF & _
"If you have a phone with email capability, please change your password on it too." & vbCRLF & vbCRLF & _
"Thank you."
objMail.Send
Set objMail = Nothing
End Sub
Sub dp (str)
If bDebug Then
objFile.WriteLine str
End If
End Sub
