'====================================

'Script Configuration Options

Const EMAIL_SERVER = "{MAILSERVER DNS OR IP ADDRESS}"

Const EMAIL_FROM = "{EMAILFROM@DOMAIN.com"

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