Identify password expiration in Active Directory

If you've got a huge amount of mobile workforce - people who are always on the go, it would be very difficult to track whether or not they change their passwords. This is very important if your users still access your network thru VPN and use their Active Directory credentials to log on. I see a lot of people who rarely log on to their domain, probably once in a month since they are always on the road, probably doing sales calls or out of the country. I wrote a script to check Active Directory for all the user accounts, check for their password expiration, and send them an email if their passwords are set to expire in less than 14 days. In a typical environment, the users will get a prompt if they log in to the domain on a regular basis. This solves the "not-so-typical" case of users rarely logging on to a domain.

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

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

strFilePath = "D:\users_DOMAIN_" & DatePart("yyyy",Now()) & strMonth & strDay & ".txt"

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")

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

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

strQuery = ";" & strFilter _
& ";displayName,pwdLastSet,userAccountControl,mail;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://dc=DOMAIN,dc=local")
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) <=14 AND DateDiff("d", Now, whenPasswordExpires) >=0 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)
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)
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, expirationDate, msgFlag)
'Accept input parameters
Dim email
Dim expirationDate
Dim strMessage

email= strEmail
expirationDate= expirationDate
strMessage= msgFlag

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

Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Message Alert from Domain Administrator: " & strMessage2
objMessage.From = "admin@domain.local"
objMessage.To = email
objMessage.TextBody = "Your domain password " & strMessage & " " & FormatDateTime(expirationDate,1) & ". This password notification notice is being sent once a week " & vbCrLF & vbCrLf & "Please change your password. "& vbCrlf & vbCrlf & vbCrlf & vbCrlf & "Domain Administrator"

'==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") = "smtp.domain.local"

'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

The use of ADO was actually not my preference since it requires you to use an additional layer just to connect to ADSI. My original script was actually using the WinNT provider to access Active Directory. But upon further research, I found out that the WinNT provider does not have pointers to access the email attribute in the user object. I need this attribute to send emails to those users whose passwords will be expiring. This prompted me to re-write my script to use the LDAP provider and ADO.

I have used the following as reference to write this script. Feel free to use it and customize in a way that suites your requirement.

http://www.rlmueller.net/
http://support.microsoft.com/kb/323750
http://msdn2.microsoft.com/en-us/library/aa772170.aspx