Email Expiration VB Script

'====================================
'Script Configuration Options
Const EMAIL_SERVER = "{MAILSERVER DNS OR IP ADDRESS}"
Const EMAIL_FROM = "{[email protected]"
Const OWA_STRING = "at {MAIL_SERVER_OWA)"


Const FIRST_REMINDER_DAY = 5
Const START_REMINDER_DAYS = 2

'Where log files will be stored
'Remember to end with \
Const LOG_PATH = "C:\scripts_Logs\"
'This setting allows you to append the date to the log file so that you get an Archive
Const APPEND_DATE = 0

'SET DEBUG MODE to 1 to send all emails to debug_email
DEBUG_MODE = 0
DEBUG_EMAIL = "{PERSONAL_TEST}@DOMAIN.COM"
'====================================


Const ADS_UF_PASSWD_CANT_CHANGE = &H40
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Const ADS_UF_ACCOUNTDISABLE = &H02


Dim strFilePath, objFSO, objFile, adoConnection, adoCommand
Dim objRootDSE, strDNSDomain, strFilter, strQuery, adoRecordset
Dim strDN, objShell, lngBiasKey, lngBias, blnPwdExpire,blnAccountDisabled
Dim objDate, dtmPwdLastSet, lngFlag, k, oDomain, maxPwdAge, numDays,whenPasswordExpires, strEmailMessage
Dim strDomain

'====================================
'Script to change a filename using timestamps
Dim strMonth, strDay
strMonth = DatePart("m", Now())
strDay = DatePart("d",Now())

if Len(strMonth)=1 Then
strMonth = "0" & strMonth
Else
strMonth = strMonth
end If

if Len(strDay)=1 Then
strDay = "0" & strDay
else
strDay = strDay
end If
'===================================

If APPEND_DATE=true Then
	strFilePath = LOG_PATH & "users_DOMAIN_" & DatePart("yyyy",Now()) & strMonth & strDay & ".txt"
Else
	strFilePath = LOG_PATH & "users_DOMAIN.txt"
End If

Set objFSO = CreateObject("Scripting.FileSystemObject")

' Open the file for write access.
On Error Resume Next
Set objFile = objFSO.OpenTextFile(strFilePath, 2, True, 0)
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "File " & strFilePath & " cannot be opened"
Set objFSO = Nothing
Wscript.Quit(1)
End If
On Error GoTo 0

' Obtain local time zone bias from machine registry.
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
& "TimeZoneInformation\ActiveTimeBias")
If (UCase(TypeName(lngBiasKey)) = "LONG") Then
lngBias = lngBiasKey
ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
lngBias = 0
For k = 0 To UBound(lngBiasKey)
lngBias = lngBias + (lngBiasKey(k) * 256^k)
Next
End If

' Use ADO to search the domain for all users.
Set adoConnection = CreateObject("ADODB.Connection")
Set adoCommand = CreateObject("ADODB.Command")
adoConnection.Provider = "ADsDSOOBject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection

' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")


strDomain = Replace(strDNSDomain, ",DC=",".")
strDomain = Replace(strDomain, "DC=","")


strBase = "<LDAP://" & strDNSDomain & ">"

' Filter to retrieve all user objects.
strFilter = "(&(objectCategory=person)(objectClass=user))"

' Filter to retrieve all computer objects.
' strFilter = "(objectCategory=computer)"

strAttributes = "displayName,pwdLastSet,userAccountControl,mail"

strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"

adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

' Iterate thru the users collection in Active Directory
objFile.WriteLine "DISPLAY NAME , PASSWORD EXPIRES, ACCOUNT DISABLED, PASSWORD LAST SET , EMAIL, PASSWORD EXPIRES, NUMBER OF DAYS"

Set oDomain = GetObject("LDAP://" & strDNSDomain)
Set maxPwdAge = oDomain.Get("maxPwdAge")


numDays = ((maxPwdAge.HighPart * 2 ^ 32) + maxPwdAge.LowPart) / -864000000000


Set adoRecordset = adoCommand.Execute
Do Until adoRecordset.EOF

Set objDate = adoRecordset.Fields("pwdLastSet").Value

lngFlag = adoRecordset.Fields("userAccountControl").Value
blnPwdExpire = True
dtmPwdLastSet = Integer8Date(objDate, lngBias)
whenPasswordExpires = DateAdd("d", numDays, dtmPwdLastSet)

If ((lngFlag And ADS_UF_PASSWD_CANT_CHANGE) <> 0) Then
blnPwdExpire = False
End If

If ((lngFlag And ADS_UF_DONT_EXPIRE_PASSWD) <> 0) Then
blnPwdExpire = False
End If

If (lngFlag And ADS_UF_ACCOUNTDISABLE) <> 0 Then
blnAccountDisabled=True
Else
blnAccountDisabled=False

If IsNull(adoRecordset.Fields("mail").Value) or IsEmpty(adoRecordset.Fields("mail").Value) Then

Else
'check if password expires
If blnPwdExpire = True Then
If (DateDiff("d", Now, whenPasswordExpires) <= START_REMINDER_DAYS AND DateDiff("d", Now, whenPasswordExpires) >=0) Or (DateDiff("d", Now, whenPasswordExpires) = FIRST_REMINDER_DAY) Then
strEmailMessage="1" 'password will expire in less than 14 days
objFile.WriteLine adoRecordset.Fields("displayName").Value & "," & blnPwdExpire & " , " & blnAccountDisabled & " , " & dtmPwdLastSet & " , " & adoRecordset.Fields("mail").Value & "," & whenPasswordExpires & "," & DateDiff("d", Now, whenPasswordExpires)
Call sendEmail(adoRecordset.Fields("mail").Value,FormatDateTime(whenPasswordExpires,2),strEmailMessage, adoRecordset.Fields("displayName").Value, strDomain)
ElseIf DateDiff("d", Now, whenPasswordExpires) <0 Then
strEmailMessage="0" 'password has already expired
objFile.WriteLine adoRecordset.Fields("displayName").Value & "," & blnPwdExpire & " , " & blnAccountDisabled & " , " & dtmPwdLastSet & " , " & adoRecordset.Fields("mail").Value & "," & whenPasswordExpires & "," & DateDiff("d", Now, whenPasswordExpires)
Call sendEmail(adoRecordset.Fields("mail").Value,FormatDateTime(whenPasswordExpires,2),strEmailMessage, adoRecordset.Fields("displayName").Value, strDomain)
End If
End If

End If
End If

adoRecordset.MoveNext
Loop

adoRecordset.Close

' Clean up.
objFile.Close
adoConnection.Close
Set objFile = Nothing
Set objFSO = Nothing
Set objShell = Nothing
Set adoConnection = Nothing
Set adoCommand = Nothing
Set objRootDSE = Nothing
Set adoRecordset = Nothing

Wscript.Echo "Done"

'=============================
'Function -Integer8 attribute function courtesy of Richard Mueller - http://www.rlmueller.net/Integer8Attributes.htm
Function Integer8Date(ByVal objDate, ByVal lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for bug in IADslargeInteger property methods.
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
Integer8Date = CDate(lngDate)
End Function

'=============================
'Send Email function
Sub sendEmail(strEmail, expirationDate1, msgFlag, Name, domain)
'Accept input parameters
Dim email
Dim expirationDate
Dim strMessage
Dim strName
Dim strDomain
Dim strMesagept2
email= strEmail
expirationDate= expirationDate1
strMessage= msgFlag
strName = Name
strDomain = domain

If strMessage=1 then
strMessage="will expire on"
strMessage2= "Password Expiration"
ElseIf strMessage=0 Then
strMessage="has expired last"
strMessage2= "Expired Password"
End If

Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Message Alert: " & strMessage2
objMessage.From = EMAIL_FROM

If DEBUG_MODE=1 Then
objMessage.To = DEBUG_EMAIL
else
objMessage.To = email
End If

objMessage.TextBody = "Hello " & strName & ","& VbCrLf & VbCrLf _
& "Your " & strDomain & " Domain password " & strMessage & " " & FormatDateTime(expirationDate,1) & "."_
& " Please Update your password as soon as possible."& VbCrLf & VbCrLf _
& "If you are on a PC that is on the Domain You can change it by pressing ALT-CTRL-DEL and then Clicking On Change Password" & VbCrLf & VbCrLf _
& "If you are on a Mac or the above does not work for you, you can change it by:"& VbCrLf & VbCrLf _
& "1." & vbTab & "Going to OWA " & OWA_STRING & VbCrLf _
& "2." & vbTab & "Clicking on Options on the Top left" & VbCrLf _
& "3." & vbTab & "Clicking on Change Password"& VbCrLf _
& vbTab & "a. The Domian is " & strDomain & VbCrLf & VbCrLf & VbCrLf

'==This section provides the configuration information for the remote SMTP server.
'==Normally you will only change the server name or IP.
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = EMAIL_SERVER

'Server port number(typically 25)
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

objMessage.Configuration.Fields.Update

objMessage.Send
Set objMessage = Nothing
End Sub