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=domain,dc=local>; (&(objectClass=user)(objectCategory=person));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
Set objLogon = objUser.LastLogon
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