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