Active directory extraction vbs script

This Script will allow you to extract from AD some useful data list (machine name, last login,) and export automatically into a .csv file. Just make sure you have enough rights to run it:



'=============================================
'
' NAME: 
'
' AUTHOR:  
' DATE  : 11/01/2012
'
' COMMENT: 
'Exemplary damages arising out of or in any way relating to the use of this script, 
'including without limitation damages for loss of goodwill, work stoppage, 
'lost profits, loss of data, and computer failure or malfunction. 
'You bear the entire risk as to the quality and performance of this script.
'
'
'============================================

Set objFSO = CreateObject("Scripting.FileSystemObject")

Dim HostName, DisName, Domain 
Dim Ruta(51) 

    'Sheets("AD_Computers").Select

Set adoCommand = CreateObject("ADODB.Command")
Set ADOConnection = CreateObject("ADODB.Connection")
ADOConnection.Provider = "ADsDSOObject"
ADOConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = ADOConnection

' Search entire Active Directory domain.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
strBase = "<LDAP://" & strDNSDomain & ">"

' Filter on computer objects.
strFilter = "(&(objectCategory=computer))"

' Comma delimited list of attribute values to retrieve.
strAttributes = "name,distinguishedName,lastLogonTimestamp,operatingSystem"

' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

' Run the query.
Set adoRecordset = adoCommand.Execute
Domain = "@Domain Name"

    Set FICHERO = objFSO.opentextfile("AD_Extract.csv", 2, True)
     FICHERO.WRITELINE "Machine Name;lastLogonTimeStamp;Operating System;System OU Name"
    FICHERO.Close

' Enumerate the resulting recordset.

Do Until adoRecordset.EOF
i = i + 1

    On Error Resume Next
    HostName = adoRecordset.Fields("name").Value
    DisName = adoRecordset.Fields("distinguishedName").Value
OS = adoRecordset.Fields("operatingSystem").Value

   Set objDate = adoRecordset.Fields("lastLogonTimeStamp").Value
    
    If (Err.Number <> 0) Then
        On Error GoTo 0
        dtmDate = #1/1/1601#
    Else
        On Error GoTo 0
        lngHigh = objDate.HighPart
        lngLow = objDate.LowPart
        If (lngLow < 0) Then
            lngHigh = lngHigh + 1
        End If
        If (lngHigh = 0) And (lngLow = 0) Then
            dtmDate = #1/1/1601#
        Else
            dtmDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) + lngLow) / 600000000 - lngBias) / 1440
        End If
    End If

    ' Display values for the user.
    If (dtmDate = #1/1/1601#) Then
        Tiempo = "Never"
    Else
        Tiempo = dtmDate
Tiempo = left(Tiempo,InStr(1,Tiempo, " ") -1)
Tiempo = day (Tiempo) & "/" & month (Tiempo)  & "/" & year (Tiempo)
    End If

    distinguishedName = DisName
     

AD = Split(DisName, ",")
    
    i2 = 50
    For Each Item In AD
      If Left(Item, 3) = "OU=" Then
       Ruta(i2) = Replace(Item, "OU=", "/")
       i2 = i2 - 1
      End If
      
    Next
    
    DisName = ""
    For i3 = 1 To 50
    If Ruta(i3) <> "" Then DisName = DisName + Ruta(i3)
    
    Next

    
    If DisName = "" Then DisName = "/COMPUTERS"
    

    Set FICHERO = objFSO.opentextfile("AD_COMPUTERS.csv", 8, True)
     on error resume next
     FICHERO.WRITELINE ucase(HostName) & ";" & Tiempo & ";" & OS & ";" & ucase(Domain & DisName)
     on error goto 0
    FICHERO.Close
    


    'Range("A" & i).Select
   ' Range("A" & i).Value = HostName
   ' Range("B" & i).Value = Domain & DisName
   ' Range("C" & i).Value = distinguishedName

'If i = 5760 Then
'MsgBox "va"
'End If
    'Move to the next record in the recordset.
     adoRecordset.MoveNext
     Erase Ruta

Loop
' Clean up.
adoRecordset.Close
ADOConnection.Close

Set adoRecordset = Nothing
Set objRootDSE = Nothing
Set ADOConnection = Nothing
Set adoCommand = Nothing

msgbox "END"