VBScript: Password Auditing Accounts w/Non-Expiring Passwords

One of the toughest scripts that I had to ever come up with, was one that would allow someone to audit active users accounts whose passwords never expire. To say the least it took quite a bit of research to get it all squared away and make it work as close as to what I wanted it to do. The script below works very well for anyone wanting to perform password audits with aforementioned criteria; however, there is a bug that prevents the script from being able to replace dates returned with 1/1/1601 in them to Null (i.e. empty). Please feel free to modify this script and use it in your environment.

P.S. - if you can correct the bug, please feel free to post the fix on the comments section below :-)

'########### ORIGINAL SOURCE ###########################################
' PwdLastChanged.vbs
' ----------------------------------------------------------------------
' Copyright (c) 2003-2010 Richard L. Mueller
' Hilltop Lab web site - http://www.rlmueller.net
'########### ORIGINAL SOURCE ###########################################

'########### Non-Expiring Password Audit ################################
' This script checks for user accounts that are in active directory,    
' whose passwords never expire, not disabled, and has not been changed 
' over 90 days.
'
' History:
' PWD_AUDIT.VBS v1.0 - 11/08/2012
' PWD_AUDIT.VBS v1.1 - 11/08/2012 - added folder & file creation handling
' PWD_AUDIT.VBS v1.2 - 11/14/2012 - added last logon for better clarity
' 
'#######################################################################

Option Explicit
Dim strFilePath, objFSO, objFile, adoConnection, adoCommand
Dim objRootDSE, strDNSDomain, strFilter, strQuery, adoRecordset
Dim strDN, objShell, lngBiasKey, lngBias, strPrncName, strLstLgDt
Dim objDate, dtmPwdLastSet, k, curDate, curMonth, curDay
Dim strFldr, strFile, strLstMnth, strFldrPath 

'Set up date variables
curDate = Date()
strLstMnth = DateAdd("m",-1,curDate)
strFldr = Year(curDate) & Right(String(2, "0") & Month(strLstMnth),2) 

'Check and see if a folder exists in the X:\pwd_audit\ directory
'using the YYYYMM format using the prior month's two digit number; if not, then create it, else create the
'CSV file using the current date in the European date format YYYYMMDD.
Dim fileSys, crtFldr

'Change the path between the quotes if needed
strFldrPath = "X:\pwd_audit\" & strFldr & "\"

Set fileSys = CreateObject("Scripting.FileSystemObject")
If Not fileSys.FolderExists(strFldrPath) Then
 Set crtFldr = fileSys.CreateFolder(strFldrPath)
End If
 
strFile = Year(curDate) & Right(String(2, "0") & Month(curDate),2) & Right(String(2, "0") & Day(curDate),2)
strFilePath = strFldrPath & strFile & ".csv"

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"
    Wscript.Quit(1)
End If
On Error GoTo 0

' Obtain local time zone bias from machine registry.
' This bias changes with Daylight Savings Time.            
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

'#################### DATE HANDLING & CONVERSTION########################################################
'# The code below first obtains the current date and then subtracts 1 quarter (3 months) from that date #
'# prior to converting it to interger8 format for the filter.           #
'########################################################################################################
Dim oocDate, dtmDateValue, dtmAdjusted, lngSeconds 'Note: oocDate is the Out of Compliance Date variable

'Subtract 1 querter (3 months) from current date
'Note: q = quarter, -1 = how many to subtract, Date() = current date
oocDate = DateAdd("q",-1,curDate) 

dtmDateValue = CDate(oocDate)

' Convert datetime value to UTC.
dtmAdjusted = DateAdd("n", lngBias, dtmDateValue)

' Find number of seconds since 1/1/1601.
lngSeconds = DateDiff("s", #1/1/1601#, dtmAdjusted)

' Convert the number of seconds to a string
' and convert to 100-nanosecond intervals.
Dim str64bit
str64Bit = CStr(lngSeconds) & "0000000"

' Filter to retrieve all user objects. 
' NOTE: The line(s) containing (!sAMAccountName=) is used for filtering out user accounts with
' a specific set of characters, those without the * (asterisk) filters out a specific account.
strFilter = "(&(objectCategory=person)(objectClass=user)(userAccountControl>=65536)(pwdLastSet<=" &_
 str64Bit & ")(!userAccountControl:1.2.840.113556.1.4.803:=2)" &_ 
 "(!sAMAccountName=Default*)(!sAMAccountName=Built-in*))" 

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

'#################### Setup AD Connection & Create CSV File #############################################
'# The code below creates the active directory connection and then uses the filter generated earlier.  #
'# From there it creates an LDAP query string and performs the actual enumeration of accounts whose     #
'# passwords never expire, along with their last password change date, username, etc. Once completed it #
'# will write each account into a comma delimited spreadsheet (CSV) file.        #
'########################################################################################################
' 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") 

strQuery = "<LDAP://" & strDNSDomain & ">;" & strFilter _
    & ";Name,pwdLastSet,userPrincipalName,lastLogon;subtree"

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

' Enumerate all users. Write each user's Distinguished Name,
' whether they are allowed to change their password, and when
' they last changed their password to the file.
objFile.WriteLine "Name,Username,Password Last Changed Date,Last Logon Date"
Set adoRecordset = adoCommand.Execute
Do Until adoRecordset.EOF
    strDN = adoRecordset.Fields("Name").Value

    ' The pwdLastSet attribute should always have a value assigned,
    ' but other Integer8 attributes representing dates could be "Null".
    If (TypeName(adoRecordset.Fields("pwdLastSet").Value) = "Object") Then
        Set objDate = adoRecordset.Fields("pwdLastSet").Value
        dtmPwdLastSet = Integer8Date(objDate, lngBias)
    Else
        dtmPwdLastSet = NULL '#1/1/1601# 'Modified to create null or empty
    End If
 
 If (TypeName(adoRecordset.Fields("lastLogon").Value) = "Object") Then
        Set objDate = adoRecordset.Fields("lastLogon").Value
        strLstLgDt = Integer8Date(objDate, lngBias)
    Else
        strLstLgDt = NULL '#1/1/1601# 'Modified to create null or empty
    End If
 
 strPrncName = adoRecordset.Fields("userPrincipalName").Value
 
    objFile.WriteLine strDN & "," & strPrncName & "," & dtmPwdLastSet & "," & strLstLgDt
    adoRecordset.MoveNext 
Loop
adoRecordset.Close

  ' Clean up.
objFile.Close
adoConnection.Close

'Open CSV file automatically after writing to it is completed
dim csvOpen
    set csvOpen = CreateObject("WScript.Shell")
     'csvOpen.Exec(strFilePath)
  csvOpen.Run Chr(34) & strFilePath & Chr(34), 1, false

  'Wscript.Echo "Done"

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 error 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
    ' Trap error if lngDate is ridiculously huge.
    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