Friday, November 9, 2007

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.


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
strMonth = strMonth
end if

if Len(strDay)=1 then
strDay = "0" & strDay
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
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)
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("
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

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

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

'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



' Clean up.
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 -
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 = "
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("") = 2

'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item("") = "smtp.domain.local"

'Server port number(typically 25)
objMessage.Configuration.Fields.Item("") = 25


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.


Anonymous said...

I am having a difficult time getting this script to work. I am getting an error message on line 124,

Set adoRecordset = adoCommand.Execute
Do Until adoRecordset.EOF

The error message is a generic one - "One or more errors occurred during processing of command."

Does anyone have any ideas?


Adam said...

I'm getting the same error and have searched all around on how to get it to work.

Looks like a great script! Thanks for the work. I'm hoping to get it working!

cbeahm said...

Did anybody get passed the adoCommand.Execute error message?

bassplayer said...

I didn't get the chance to reply to your posts due to much work :-)

Have you managed to solve your issues? I have written something similar - and simpler - using PowerShell

Andy said...

I have not gotten past the error that they were having above.

Set adoRecordset=adoCommand.Execute

This script is exactly what i need for our environment, just need to get past this.

Is it an authentication, or a user account problem?

bassplayer said...

What's the exact error message? have you tried the PowerShell version of the script?

Andy said...

It was just the generic message saying that one or more errors occurred during processing the command.

I looked at the PowerShell script, but it doesnt appear to send a notification email. That piece is important to me since none of my users log onto the domain, they are all spread across the country.

Andy said...

in the process of steping through the script, trying to determine where it failed, Line 91 was all the info it gave, we determined it failed at the line
Set adoRecordset=adoCommand.Execute

Krisz said...

The strQuery causing the problem.
The LDAP connection not defined correctly (the ; is not enough).

Can't publish the solution here because the site is blocking, but check this for example:

Good luck

bassplayer said...

I think the entire script is getting formatted by the site. If the adoCommand.Execute is failing, it means that there is something wrong with the query itself, which is defined by strQuery. If you are still having problems, you can send me an IM on MSN

Anonymous said...

The fixed and updated script is at:

Du said...

This one above worked very well!!! Thanks ;)