Notifying users via e-mail that their password is about to expire

Most companies I have ever worked for have off site people. Even if they connect to the network via a VPN client, these users will not get a pop up notifying them that thier password will expire in X days. The only way to enable this functionality is to put a hardware VPN at thier location (very expensive and usually very slow). I have asked sales people to make an entry on thier calander 90 days after they change thier password as a reminder. I have even gone as far as to make a recurring schedule on thier calander. Nothing worked. So I created the following script that will go through the AD and e-mail users whose passwords are expiring in 8 days or less. Now there really is not excuse for those pesky sales people. If you set debugMode = "True" then it will pop up messages as the script runs (assumes WScript) and will e-mail the message to the debugEmail address instead of the recipients. The top of the script contains just about all the custom information in variables that most people will use.

Assumptions:
1) You are running Exchange with OWA enabled.
2) Your OWA is configured to allow for password changes.
3) The e-mail address of the user is thier primary address as specified in the AD object.

Disclaimer: I started out with someone else's script and then modified it greatly. I don't know who that person was.

--------------------------------------------------------
--------------------------------------------------------
Option Explicit

Dim objCommand, objConnection, strBase
Dim strFilter, strAttributes, strPasswordChangeDate, intPassAge
Dim lngTZBias, objPwdLastSet, strEmailAddress
Dim objShell, lngBiasKey, k, PasswordExpiry, strRootDomain
Dim strQuery, objRecordset, strName, strCN
Dim objEmail, objFSO, strDisabled, debugMode
Dim debugEmail, SMTPServer, owaURL, supportContact

debugMode = "True"
debugEmail = "test@yourdomain.com"

' // Enter the number of days passwords are good for in your domain
PasswordExpiry = 90
' // Enter domain information
strRootDomain = "dc=yourdomain,dc=com"
' // URL or IP of SMTP Server
SMTPServer = "mail.yourdomain.com"
' // URL to OWA server for e-mail message
owaURL = "https://mail.yourdomain.com/owa"
supportContact = "Joe Blow (xxx) xxx-xxxx"

Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")

' // HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias
' //This value is the current time difference from Greenwich Mean Time (GMT) in minutes and is the difference for GMT.
' // For example, if youÆre 1 hour ahead, GMT is 1 hour behind. The value would be ffffffc4, which is hexadecimal for -60.
' // Need to ensure this is in a format we can use.
If UCase(TypeName(lngBiasKey)) = "LONG" Then
lngTZBias = lngBiasKey
ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then
lngTZBias = 0
For k = 0 To UBound(lngBiasKey)
lngTZBias = lngTZBias + (lngBiasKey(k) * 256^k)
Next
End If


Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
strBase = "<LDAP://" & strRootDomain & ">"


' // Filter on users do not have "password never expires"
' // or "password not required" set.
' // userAccountControl:1.2.840.113556.1.4.803:=65536 ' // User accounts with no pwd expiry
' // userAccountControl:1.2.840.113556.1.4.803:=32 ' // User accounts with no pwd required
' // userAccountControl:1.2.840.113556.1.4.803:=2 ' // Checks to see if the account is disabled
strFilter = "(&(objectCategory=person)(objectClass=user)" _
& "(!userAccountControl:1.2.840.113556.1.4.803:=65536)" _
& "(!userAccountControl:1.2.840.113556.1.4.803:=32)" _
& "(!userAccountControl:1.2.840.113556.1.4.803:=2))"
strAttributes = "sAMAccountName,cn,mail,pwdLastSet"
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
objCommand.CommandText = strQuery
objCommand.Properties("Page Size") = 100
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
Set objRecordSet = objCommand.Execute

' // Debug mode pops up messages (WScript) while the script is running.
' // Also e-mails a debug e-mail account rather than the user
If debugMode = "True" then
WScript.echo "Today's date used in password calculations: " & FormatDateTime(Date() ,1)
End if

Do Until objRecordSet.EOF
strName = objRecordSet.Fields("sAMAccountName").Value
strCN = objRecordSet.Fields("cn").value

strEmailAddress = objRecordSet.Fields("mail").value

Set objPwdLastSet = objRecordset.Fields("pwdLastSet").Value


strPasswordChangeDate = Integer8Date(objPwdLastSet, lngTZBias)
intPassAge = DateDiff("d", strPasswordChangeDate, Now)

if debugMode = "True" then
Wscript.Echo "NT Name: " & strName & ", Common Name: " & strCN & vbCRLF & vbCRLF _
& vbTab & "Password last changed at " & strPasswordChangeDate & vbCRLF & vbCRLF _
& vbTab & "Password changed " & intPassAge & " days ago" & vbCRLF & vbCRLF _
& vbTab & "E-mail: " & strEmailAddress & vbCRLF & vbCRLF _
& vbTAB & "Password Change Date: " & strPasswordChangeDate
End If

If not ( strPasswordChangeDate = "1/1/1601") then ' // Filter new users who have to change their password at first login.
' // If a password change has never happened the date of last password changed
' // is equal to January 1st, 1601.
If (intPassAge > PasswordExpiry) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password has expired"
End if
Call SendEmailMessage(strEmailAddress, 0)
ElseIf intPassAge = (PasswordExpiry - 1) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 1 days"
End if
Call SendEmailMessage(strEmailAddress, 1)
ElseIf intPassAge = (PasswordExpiry - 2) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 2 days"
End if
Call SendEmailMessage(strEmailAddress, 2)
ElseIf intPassAge = (PasswordExpiry - 3) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 3 days"
End if
Call SendEmailMessage(strEmailAddress, 3)
ElseIf intPassAge = (PasswordExpiry - 4) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 4 days"
End if
Call SendEmailMessage(strEmailAddress, 4)
ElseIf intPassAge = (PasswordExpiry - 5) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 5 days"
End if
Call SendEmailMessage(strEmailAddress, 5)
ElseIf intPassAge = (PasswordExpiry - 6) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 6 days"
End if
Call SendEmailMessage(strEmailAddress, 6)
ElseIf intPassAge = (PasswordExpiry - 7) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 8 days"
End if
Call SendEmailMessage(strEmailAddress, 7)
ElseIf intPassAge = (PasswordExpiry - 8) Then
If debugMode = "True" then
WScript.echo vbTab & "Sending user notification to " _
& strEmailAddress & " that password expires in 8 days"
End if
Call SendEmailMessage(strEmailAddress, 8)
End If
End If

objRecordSet.MoveNext
Loop

objConnection.Close


Function Integer8Date(objDate, lngBias)
Dim lngAdjust, lngDate, lngHigh, lngLow

lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart

If lngLow < 0 Then
lngHigh = lngHigh + 1
End If

If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If

lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) + lngLow) / 600000000 - lngAdjust) / 1440

On Error Resume Next
Integer8Date = CDate(lngDate)
If Err.Number <> 0 Then
On Error GoTo 0
Integer8Date = #1/1/1601#
End If
On Error GoTo 0

End Function

Sub SendEmailMessage (strDestEmail,strNoOfDays)

Set objEmail = CreateObject("CDO.Message")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = WScript.CreateObject ("WScript.Shell")

If IsNull(strDestEmail) Then
If debugMode = "True" then
Wscript.Echo "No email address, no message sent."
End If
Exit Sub
End If

objEmail.From = "Password_manager@1stAmericard.com"
If debugMode = "True" then
objEmail.To = debugEmail
wscript.echo "Using debug e-mail address: " & debugEmail
Else
objEmail.To = strDestEmail
End if
objEmail.Subject = "Your e-mail password is set to expire in " & strNoOfDays & " days!!"
objEmail.Textbody = "The password for account " & strDestEmail & " will expire in " & strNoOfDays & " days!!" & vbCRLF & vbCRLF _
& "It is very important that you change your password before it expires. Here is some important information " _
& "you will need regarding your password." & vbCRLF & vbCRLF _
& "Current password policy:" & vbCRLF _
& vbTAB & " 1) Passwords are only good for 90 days" & vbCRLF _
& vbTAB & " 2) Passwords must be unique. You cannot reuse your last 4 passwords" & vbCRLF _
& vbTAB & " 3) Passwords must be strong and contain 3 of the following 4 classes of characters" & vbCRLF _
& vbTAB & vbTAB & " a) Upper case characters (i.e. ABCDE....)" & vbCRLF _
& vbTAB & vbTAB & " b) Lower case characters (i.e. abcde....)" & vbCRLF _
& vbTAB & vbTAB & " c) Numbers (i.e. 12345....)" & vbCRLF _
& vbTAB & vbTAB & " d) Special characters (i.e. !@#$%....)" & vbCRLF & vbCRLF _
& "For security reasons, it is recommended that you use a pass phrase rather than a password. Pass " _
& "phrases contain spaces and are much more secure." & vbCRLF _
& "Examples of pass phrases are: " & vbCRLF & vbCRLF _
& vbTAB & " My spouse is groovy!" & vbCRLF _
& vbTAB & " I shot a 76" & vbCRLF _
& vbTAB & " My 4 kids" & vbCRLF & vbCRLF _
& "How to change your password" & vbCRLF _
& vbTAB & "1) Go to " & owaURL & " and log into your Outlook Web Access account." & vbCRLF _
& vbTAB & "2) Select OPTIONS in the upper right hand corner." & vbCRLF _
& vbTAB & "3) Click on the CHANGE PASSWORD option on the left column." & vbCRLF _
& vbTAB & "4) Type your old password and your new password based upon the above criteria." & vbCRLF & vbCRLF & vbCRLF _
& "Please note that Outlook Web Access is designed primarily for use on Internet Explorer. " _
& "We have received several reports of issues with users on Apple computers trying to change thier password. " _
& "If you require assistance, please contact " & supportContact

objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
objEmail.Send

End Sub