Windows - Password Expiration Warning Sent By Email

posted 19 Jan 2017, 08:49 by Dominique Cressatti   [ updated 29 Jun 2018, 11:14 ]

Purpose: VB script notifying by email Active directory users when their passwords are about to expire.
Useful for: users who aren't using Windows workstations or not directly connected to an AD domain through a VPN, hence not being able to receive the notification that their password is about to expire and could result in locking their AD account.

What you need to have and do:
  • Set the STRFROM variable as the "From" address of the email (usually administrator@yourdomain.com).
  • Set the DAYS_FOR_EMAIL variable as the number of days when to start notifying users that their password is about to expire (usually 7).
  • Set the ExcludedGroup variable as the AD group name (which you'll have to create) which contains the list of users who don't need to be notified (because they either use a Windows workstation or are connected to the AD domain through something like a VPN).
  • Set the  ExchangeServerFQN variable as to your Exchange server FQN
  • You may also want to amend the email body
  • Schedule to run this script every day at midnight using either with Windows AT or better the Windows scheduler

'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  = ""
Const SMTP_SERVER  = "127.0.0.1"
Const STRFROM   = "<admin@somecompany.com>"
Const DAYS_FOR_EMAIL  = 7
Const ExcludedGroup = "_Excluded"
Const ExchangeServerFQN = "yourexchangeserver@yourdomain.com"

'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   = true

Dim objRoot
Dim numDays, iResult
Dim strDomainDN
Dim objContainer, objSub
Dim UserName, UserExcluded, EmailAddress
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 he 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
     UserExcluded = 0
     UserName = ""
     EmailAddress = ""
     UserName = LCase(Mid (objUser.Name, 4))
     EmailAddress = objUser.Mail
     dp "" & vbCRLF
     dp "User name: " & UserName
     dp "Email address: " &  EmailAddress
     'Here we check  if the user account is part of excluded group
     Dim GroupName, Group, IsInExcludedGroup, CheckIfArray
     IsInExcludedGroup = 0
     Group = objUser.memberof
     CheckIfArray = IsArray(Group) 
     'Checking that the group name is not empty, else skip group checking
     If Not IsEmpty(Group) And CheckIfArray = "True" Then 
       For Each GroupName In Group
           'checking if group string contains the excluded group name
           IsInExcludedGroup = InStr (GroupName, ExcludedGroup) 
          If IsInExcludedGroup <> 0 Then
             UserExcluded = 1
            dp "is part of the group: " & ExcludedGroup
          End If
       Next
     End if
     ' Checking that the group name is not empty, else skip group checking
     If Not IsEmpty(Group) And CheckIfArray = "False" Then 
        'checking if group string contains the excluded group name
        IsInExcludedGroup = InStr (Group, ExcludedGroup)
        If IsInExcludedGroup <> 0 Then
          UserExcluded = 1
          dp "is part of the group: " & ExcludedGroup
        End If
     End If
    'checking if user account begin with a $ or has no mailbox
     If (UserExcluded <> 1) And Right (objUser.Name, 1) <> "$" Then
       If IsEmpty (objUser.Mail) or IsNull  (objUser.Mail) Then
         dp "has no mailbox"
         UserExcluded = 1
       End If
     End If
    ' checking if account password is expired or doesnt expire
    If UserExcluded <> 1 Then
       If UserIsExpired (objUser, iMaxPwdAge, DAYS_FOR_EMAIL, iResult) Then
         WScript.Echo "...sending an email for " & objUser.Mail
         dp "Sending email"
         Call SendEmail (objUser, iResult)
       End If
    Else
       dp "...don't send an email"
    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  = "Your Windows password needs to be changed soon"
  objMail.Textbody = "Hi," & vbCRLF & vbCRLF & _
     "Your Windows password will expire soon." & vbCRLF & _
     "The password for the account: " & objUser.userPrincipalName & _
      " (" & objUser.sAMAccountName & ")" & vbCRLF & _
     "will expire in " & iResult & " days. Please change it as soon as possible." & vbCRLF & vbCRLF & _
     "You can change it from the Internet by login on: " & vbCRLF & _
     "https://<ExchangeServerFQN>/owa" & vbCRLF & _
     "(Note: Your Web browser is likely to warn you against using the above Web site, it is because we are using a self-signed certificate and it is safe to continue)" & vbCRLF & vbCRLF & _
     "If you would prefer not to receive this reminder, just send a reply with the subject line: opt out of password reminder" & 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
Liking it? Plus it☺️