One of the less attractive aspects of a career in security is routine auditing. It’s boring, but it still needs to be done. As users leave the HR department should notify IT and the account should be disabled or set to expire on their last day in the office. The process can go wrong at HR or in IT.
To make the audit task a little easier I came up with a VBA macro for excel. Active directory is queried for all user accounts that are not disabled by running the AD_QUERY macro. The spreadsheet is populated with a list of all active accounts. The CopyPW and CopyLstLogon macros will add an additional worksheet each which contains filtered lists of accounts with passwords that don’t expire, and last logons greater than 90 days.
The need to change passwords is obvious, but the last logon timestamp being greater than 90 days is a good indicator that someone has left and there was a process failure, or that it was a test account that should have been deleted.
To use the macros just create a new spreadsheet and open the VBA editor using ALT-F11, right click on VBAPROJECT(Book1) and select insert then module from the context menu. Copy the code from listing 1 and paste it into the new module. Close the VBA editor and your ready to run the macros.
Hope this makes life a little easier for you if your doing the account audits.
Listing 1
Option Explicit Const ADS_UF_ACCOUNTDISABLE = 2 Const ADS_SCOPE_SUBTREE = 2 Const ADS_UF_DONT_EXPIRE_PASSWD = 65536 Const FLD_FULLNAME = 1 Const FLD_SAM_ACCTNAME = 2 Const FLD_CREATEDATE = 3 Const FLD_PWD_LASTCHNG = 4 Const FLD_PWD_DONTEXPIRE = 5 Const FLD_UAC = 6 Const FLD_LASTLOGON = 7 Const FLD_ADSPATH = 8 Const FLD_MAX = 8 Const HEADROW = 1 Const ASCII_OFFSET = 64 Sub AD_QUERY() Dim objUser, objLogon, objConnection, objCommand, objRecordSet Dim strPath, strFullName, strSamAccountName Dim intUAC, intLogonTime Dim createdate, pwdchanged Dim Disabled, PWDexpire, intCounter Dim objsheet As Excel.Worksheet Dim rngData As Excel.Range Set objConnection = CreateObject("ADODB.Connection") Set objCommand = CreateObject("ADODB.Command") objConnection.Provider = "ADsDSOObject" objConnection.Properties("ADSI Flag") = 1 objConnection.Open "Active Directory Provider" Set objCommand.ActiveConnection = objConnection objCommand.Properties("Page Size") = 10000 objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 'Search AD Global catalog for user objects that are not disabled objCommand.CommandText = "<GC://dc=acme,dc=com,dc=au>;" & _ "(&(objectClass=user)(objectCategory=person)(!userAccountControl:1.2.840.113556.1.4.803:=2));" & _ "adspath, samAccountName; subtree" Application.StatusBar = "Executing AD Query. Please wait..." Set objRecordSet = objCommand.Execute Application.StatusBar = "Populating Worksheet with data. Please wait..." Set objsheet = Application.ActiveWorkbook.Worksheets.Add() objsheet.Name = Format(Date, "dd-mm-yyyy") & " Raw Data" intCounter = 2 'Initialise worksheet row counter objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name" objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name" objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)" objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed" objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire" objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC" objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp" objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH" objRecordSet.MoveFirst Do Until objRecordSet.EOF strPath = objRecordSet.Fields("adspath") 'Change the global catalog path to an ldap path so that we can access 'all the attributes when binding to the object. strPath = Replace(strPath, "GC://", "LDAP://") Set objUser = GetObject(strPath) intUAC = objUser.userAccountControl If (intUAC And ADS_UF_DONT_EXPIRE_PASSWD) = 0 Then PWDexpire = False Else PWDexpire = True End If On Error Resume Next Err.Clear Set objLogon = objUser.LastLogonTimestamp If Err.Number <> 0 Then intLogonTime = 0 Err.Clear Else intLogonTime = objLogon.HighPart * (2 ^ 32) + objLogon.LowPart intLogonTime = intLogonTime / (60 * 10000000) intLogonTime = intLogonTime / 1440 End If strFullName = objUser.FullName If Err.Number <> 0 Then strFullName = "" Err.Clear End If createdate = objUser.whenCreated If Err.Number <> 0 Then createdate = "" Err.Clear End If pwdchanged = objUser.passwordLastChanged If Err.Number <> 0 Then pwdchanged = "" Err.Clear End If On Error GoTo 0 strSamAccountName = objUser.SamAccountName objsheet .Cells(intCounter, FLD_FULLNAME).Value = strFullName objsheet.Cells(intCounter, FLD_SAM_ACCTNAME).Value = strSamAccountName objsheet.Cells(intCounter, FLD_CREATEDATE).Value = createdate objsheet.Cells(intCounter, FLD_PWD_LASTCHNG).Value = pwdchanged objsheet.Cells(intCounter, FLD_PWD_DONTEXPIRE).Value = PWDexpire objsheet.Cells(intCounter, FLD_UAC).Value = intUAC If intLogonTime <> 0 Then objsheet.Cells(intCounter, FLD_LASTLOGON).Value = intLogonTime + #1/1/1601# Else objsheet.Cells(intCounter, FLD_LASTLOGON).Value = "#1/1/1601#" End If objsheet.Cells(intCounter, FLD_ADSPATH).Value = strPath objRecordSet.MoveNext intCounter = intCounter + 1 Loop Set rngData = objsheet.Range("A1:" & Chr(ASCII_OFFSET + FLD_MAX) & intCounter - 1) 'if the named range already exists we need to delete is before we create it again. 'This will allow more than one audit set to be retained in the same workbook. On Error Resume Next ActiveWorkbook.Names("AD_DATA_SET").Delete On Error GoTo 0 rngData.Name = "AD_DATA_SET" rngData.Columns.AutoFit Application.StatusBar = "Ready" End Sub Sub filter_lastlogon() Dim rngData As Excel.Range Set rngData = Range("AD_DATA_SET") rngData.Worksheet.AutoFilterMode = False 'Filter function seems to ignore locale info so dates must be in US format rngData.autofilter Field:=FLD_LASTLOGON, Criteria1:="=#1/1/1601#", Operator:=xlOr, _ Criteria2:="<" & Format(Now() - 90, "mm/dd/yyyy") End Sub Sub filter_pwd_dontexpire() Dim rngData As Excel.Range Set rngData = Range("AD_DATA_SET") rngData.Worksheet.AutoFilterMode = False rngData.autofilter Field:=FLD_PWD_DONTEXPIRE, Criteria1:="=True" End Sub Sub RemoveFilter() Dim rngData As Excel.Range Set rngData = Range("AD_DATA_SET") rngData.Worksheet.AutoFilterMode = False End Sub Sub CopyPW() 'Copies the filtered data to a new Worksheet 'Code modified from http://www.contextures.com/xlautofilter03.html#Copy 'Viewed 7/6/2007 Dim rngData As Excel.Range Dim rng As Range Dim rng2 As Range Dim objsheet As Worksheet Set rngData = Range("AD_DATA_SET") Call filter_pwd_dontexpire If Not rngData.Worksheet.FilterMode Then MsgBox "Filter Data before selecting this option", vbExclamation Exit Sub End If With rngData.Worksheet.autofilter.Range On Error Resume Next Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _ .SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If rng2 Is Nothing Then MsgBox "No data to copy" Else Set objsheet = Application.ActiveWorkbook.Worksheets.Add() objsheet.Name = Format(Date, "dd-mm-yyyy") & " Password dont expire" Set rng = rngData.Worksheet.autofilter.Range rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _ Destination:=objsheet.Range("A2") objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name" objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name" objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)" objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed" objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire" objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC" objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp" objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH" objsheet.Columns.AutoFit End If End Sub Sub CopyLstLogon() 'Copies the filtered data to a new Worksheet 'Code modified from http://www.contextures.com/xlautofilter03.html#Copy 'Viewed 7/6/2007 Dim rngData As Excel.Range Dim rng As Range Dim rng2 As Range Dim objsheet As Worksheet Set rngData = Range("AD_DATA_SET") Call filter_lastlogon If Not rngData.Worksheet.FilterMode Then MsgBox "Filter Data before selecting this option", vbExclamation Exit Sub End If With rngData.Worksheet.autofilter.Range On Error Resume Next Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _ .SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If rng2 Is Nothing Then MsgBox "No data to copy" Else Set objsheet = Application.ActiveWorkbook.Worksheets.Add() objsheet.Name = Format(Date, "dd-mm-yyyy") & " LastLogon > 90 days" Set rng = rngData.Worksheet.autofilter.Range rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _ Destination:=objsheet.Range("A2") objsheet.Cells(HEADROW, FLD_FULLNAME).Value = "Full Name" objsheet.Cells(HEADROW, FLD_SAM_ACCTNAME).Value = "SAM Account name" objsheet.Cells(HEADROW, FLD_CREATEDATE).Value = "Create Date (UTC)" objsheet.Cells(HEADROW, FLD_PWD_LASTCHNG).Value = "PWD Last Changed" objsheet.Cells(HEADROW, FLD_PWD_DONTEXPIRE).Value = "PWD Don't Expire" objsheet.Cells(HEADROW, FLD_UAC).Value = "UAC" objsheet.Cells(HEADROW, FLD_LASTLOGON).Value = "LastLogonTimestamp" objsheet.Cells(HEADROW, FLD_ADSPATH).Value = "ADSPATH" objsheet.Columns.AutoFit End If End Sub