Attribute VB_Name = "Module1"
Option Explicit

' Globals
Dim objConn, objCmd, objRs, lngBias

Sub SetupConnections()
    Set objConn = CreateObject("ADODB.Connection")
    Set objCmd = CreateObject("ADODB.Command")
    objConn.Provider = "ADsDSOObject"
	objConn.Open "Active Directory Provider"
    objCmd.ActiveConnection = objConn
End Sub

Sub KillConnections()
    objConn.Close
    Set objConn = Nothing
    Set objCmd = Nothing
End Sub


Sub PopulateHeaders(SheetName)
    Dim cSheet As Worksheet
    Dim arrHeaders, i
    
    Set cSheet = ThisWorkbook.Sheets(SheetName)
    arrHeaders = Array("Hostname", "Password Last Set", "Day Count", "Recent", "Disabled?", "Top Level OU", "OU", "Distinguished Name")
    
    For i = 0 To UBound(arrHeaders)
        cSheet.Cells(1, i + 1) = arrHeaders(i)
    Next
End Sub

Function getTopLevelOUs()
    Dim objRootDSE, strBaseConnString, objOULevel, objOUObject, tmp
    
    Set objRootDSE = GetObject("LDAP://RootDSE")
    strBaseConnString = objRootDSE.Get("defaultNamingContext")
    Set objOULevel = GetObject("LDAP://" & strBaseConnString)
    tmp = ""
    For Each objOUObject In objOULevel
        tmp = tmp & "LDAP://" & objOUObject.distinguishedName & "|"
    Next
    tmp = Left(tmp, Len(tmp) - 1)
    
    getTopLevelOUs = Split(tmp, "|")
End Function

Function getComputers(qry, intDays)
    Dim objComp, objDate
    Dim strName, dtmPwdLastSet, strOU, strSite, strOut, strTopOU
    Dim comp, tmp, disabled
    objCmd.CommandText = qry
	objCmd.Properties("Page Size") = 1000
	objCmd.Properties("Timeout") = 300
	objCmd.Properties("Cache Results") = False
	objCmd.Properties("Size Limit") = 75000
    Set objRs = objCmd.Execute
    
    strOut = ""
    While Not objRs.EOF
      If strOut <> "" Then
        strOut = strOut & vbCrLf
      End If
      ' Get the LDAP Record
      ' use distinguished name to provide a direct link to the object
      comp = "LDAP://" & objRs.Fields("distinguishedName")
      ' Create a Computer object
      Set objComp = GetObject(comp)
      Set objDate = objComp.PwdLastSet
      dtmPwdLastSet = Integer8Date(objDate, lngBias)
      
      'Is Computer account Disabled?
      If objComp.AccountDisabled <> 0 Then
        disabled = "TRUE"
      Else
        disabled = "FALSE"
      End If
      
      strName = objComp.sAMAccountName
      strName = Left(strName, Len(strName) - 1)
      
      ' Normalise OU so it is user friendly and get site
      tmp = Split(objComp.distinguishedName, ",")
      strOU = ""
      Dim i
      For i = UBound(tmp) To 1 Step -1
        If (i = UBound(tmp)) Then
          strOU = Right(tmp(i - 1), Len(tmp(i - 1)) - 3) & "." & Right(tmp(i), Len(tmp(i)) - 3)
          strTopOU = Right(tmp(i - 2), Len(tmp(i - 2)) - 3)
          i = i - 1
        Else
          strOU = strOU & "/" & Right(tmp(i), Len(tmp(i)) - 3)
        End If
      Next
      
      Dim recent, ddiff
      ddiff = DateDiff("d", dtmPwdLastSet, Now)
      If (ddiff > intDays) Then
        recent = "FALSE"
      Else
        recent = "TRUE"
      End If
      
        If strOut <> "" Then
            strOut = strOut & "," & strName & "," & dtmPwdLastSet & "," & ddiff & "," & _
                recent & "," & disabled & "," & strTopOU & "," & strOU & "," & Replace(objRs.Fields("distinguishedName"), ",", "|")
        Else
            strOut = strName & "," & dtmPwdLastSet & "," & ddiff & "," & _
                recent & "," & disabled & "," & strTopOU & "," & strOU & "," & Replace(objRs.Fields("distinguishedName"), ",", "|")
        End If
      objRs.MoveNext
    Wend
    If (strOut <> "") Then
        getComputers = strOut
    Else
        getComputers = ""
    End If
    
    Set objComp = Nothing
    Set objRs = Nothing
    Set objDate = Nothing
End Function

Sub getTimeBias()
    ' Obtain the local time zone bias from machine registry
    Dim objShell, lngBiasKey
    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
End Sub

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