Password change reminder script for all AD

If you have remote users in your domain, they are not notified by the DC when their password is about to expire, because they open their windows session before the VPN client can connect to the DC.

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