Export Active Directory Users to Excel Worksheet

This script when run will export every "user" object in Active Directory and put into an Excel Spreadsheet.  This will also include any and all SMTP alisas' (up to 20), that an account has.

Hope this might come in handy for someone.

UPDATED 3/7/2006  (please re-copy and paste if you use this already)  I had a small error in script which wasn't getting the email address property reported on the one that's displayed on the "General" tab in ADUC (it showed up in excel as blank).  Please note, there are 2 different locations for email, 1 on the General TAB in ADUC and another on the Email Addresses tab. (the one that was reporting blank was the one on the "General" tab.

-Eric

PS - I've posted the "write back" version of this script on another reply post.

---

 Dim ObjWb 
 Dim ObjExcel 
 Dim x, zz 
 Set objRoot = GetObject("LDAP://RootDSE") 
 strDNC = objRoot.Get("DefaultNamingContext") 
 Set objDomain = GetObject("LDAP://" & strDNC) ' Bind to the top of the Domain using LDAP using ROotDSE 
 Call ExcelSetup("Sheet1") ' Sub to make Excel Document 
 x = 1 
 Call enummembers(objDomain) 
 Sub enumMembers(objDomain) 
 On Error Resume Next 
 Dim Secondary(20) ' Variable to store the Array of 2ndary email alias's 
 For Each objMember In objDomain ' go through the collection 
 
 If ObjMember.Class = "user" Then ' if not User object, move on. 
 x = x +1 ' counter used to increment the cells in Excel 
 
    objwb.Cells(x, 1).Value = objMember.Class 
    ' I set AD properties to variables so if needed you could do Null checks or add if/then's to this code 
    ' this was done so the script could be modified easier. 
 SamAccountName = ObjMember.samAccountName 
 Cn = ObjMember.CN 
 FirstName = objMember.GivenName 
 LastName = objMember.sn 
 initials = objMember.initials 
 Descrip = objMember.description 
 Office = objMember.physicalDeliveryOfficeName 
 Telephone = objMember.telephonenumber 
 EmailAddr = objMember.mail 
 WebPage = objMember.wwwHomePage 
 Addr1 = objMember.streetAddress 
 City = objMember.l 
 State = objMember.st 
 ZipCode = objMember.postalCode 
 Title = ObjMember.Title 
 Department = objMember.Department 
 Company = objMember.Company 
 Manager = ObjMember.Manager 
 Profile = objMember.profilePath 
 LoginScript = objMember.scriptpath 
 HomeDirectory = ObjMember.HomeDirectory 
 HomeDrive = ObjMember.homeDrive 
 AdsPath = Objmember.Adspath 
 LastLogin = objMember.LastLogin 
 
 zz = 1 ' Counter for array of 2ndary email addresses 
 For each email in ObjMember.proxyAddresses 
     If Left (email,5) = "SMTP:" Then 
 Primary = Mid (email,6) ' if SMTP is all caps, then it's the Primary 
     ElseIf Left (email,5) = "smtp:" Then 
        Secondary(zz) = Mid (email,6) ' load the list of 2ndary SMTP emails into Array. 
        zz = zz + 1 
     End If 
 Next 
 ' Write the values to Excel, using the X counter to increment the rows. 
 
 objwb.Cells(x, 2).Value = SamAccountName 
 objwb.Cells(x, 3).Value = CN 
 objwb.Cells(x, 4).Value = FirstName 
 objwb.Cells(x, 5).Value = LastName 
 objwb.Cells(x, 6).Value = Initials 
 objwb.Cells(x, 7).Value = Descrip 
 objwb.Cells(x, 8).Value = Office 
 objwb.Cells(x, 9).Value = Telephone 
 objwb.Cells(x, 10).Value = EmailAddr
 objwb.Cells(x, 11).Value = WebPage 
 objwb.Cells(x, 12).Value = Addr1 
 objwb.Cells(x, 13).Value = City 
 objwb.Cells(x, 14).Value = State 
 objwb.Cells(x, 15).Value = ZipCode 
 objwb.Cells(x, 16).Value = Title 
 objwb.Cells(x, 17).Value = Department 
 objwb.Cells(x, 18).Value = Company 
 objwb.Cells(x, 19).Value = Manager 
 objwb.Cells(x, 20).Value = Profile 
 objwb.Cells(x, 21).Value = LoginScript 
 objwb.Cells(x, 22).Value = HomeDirectory 
 objwb.Cells(x, 23).Value = HomeDrive 
 objwb.Cells(x, 24).Value = Adspath 
 objwb.Cells(x, 25).Value = LastLogin 
 objwb.Cells(x,26).Value = Primary 
 
 ' Write out the Array for the 2ndary email addresses. 
 For ll = 1 To 20 
 objwb.Cells(x,26+ll).Value = Secondary(ll) 
 Next 
 ' Blank out Variables in case the next object doesn't have a value for the property 
 SamAccountName = "-" 
 Cn = "-" 
 FirstName = "-" 
 LastName = "-" 
 initials = "-" 
 Descrip = "-" 
 Office = "-" 
 Telephone = "-" 
 EmailAddr = "-" 
 WebPage = "-" 
 Addr1 = "-" 
 City = "-" 
 State = "-" 
 ZipCode = "-" 
 Title = "-" 
 Department = "-" 
 Company = "-" 
 Manager = "-" 
 Profile = "-" 
 LoginScript = "-" 
 HomeDirectory = "-" 
 HomeDrive = "-" 
 Primary = "-" 
 For ll = 1 To 20 
 Secondary(ll) = "" 
 Next 
    End If 
    
    ' If the AD enumeration runs into an OU object, call the Sub again to itinerate 
    
    If objMember.Class = "organizationalUnit" or OBjMember.Class = "container" Then 
        enumMembers (objMember) 
    End If 
 Next 
 End Sub 
 Sub ExcelSetup(shtName) ' This sub creates an Excel worksheet and adds Column heads to the 1st row 
 Set objExcel = CreateObject("Excel.Application") 
 Set objwb = objExcel.Workbooks.Add 
 Set objwb = objExcel.ActiveWorkbook.Worksheets(shtName) 
 Objwb.Name = "Active Directory Users" ' name the sheet 
 objwb.Activate 
 objExcel.Visible = True 
 objwb.Cells(1, 2).Value = "SamAccountName" 
 objwb.Cells(1, 3).Value = "CN" 
 objwb.Cells(1, 4).Value = "FirstName" 
 objwb.Cells(1, 5).Value = "LastName" 
 objwb.Cells(1, 6).Value = "Initials" 
 objwb.Cells(1, 7).Value = "Descrip" 
 objwb.Cells(1, 8).Value = "Office" 
 objwb.Cells(1, 9).Value = "Telephone" 
 objwb.Cells(1, 10).Value = "Email" 
 objwb.Cells(1, 11).Value = "WebPage" 
 objwb.Cells(1, 12).Value = "Addr1" 
 objwb.Cells(1, 13).Value = "City" 
 objwb.Cells(1, 14).Value = "State" 
 objwb.Cells(1, 15).Value = "ZipCode" 
 objwb.Cells(1, 16).Value = "Title" 
 objwb.Cells(1, 17).Value = "Department" 
 objwb.Cells(1, 18).Value = "Company" 
 objwb.Cells(1, 19).Value = "Manager" 
 objwb.Cells(1, 20).Value = "Profile" 
 objwb.Cells(1, 21).Value = "LoginScript" 
 objwb.Cells(1, 22).Value = "HomeDirectory" 
 objwb.Cells(1, 23).Value = "HomeDrive" 
 objwb.Cells(1, 24).Value = "Adspath" 
 objwb.Cells(1, 25).Value = "LastLogin" 
 objwb.Cells(1, 26).Value = "Primary SMTP" 
 End Sub 
 MsgBox "Done" ' show that script is complete 
 

have you tried this script on an AD domain that has more than 1000 users?

i have run into this problem before and know how to get around it, just wondering if yours is able to or not.

I haven't run it with over 1K users, but yes, it will not work unless you use ADO and LDAP query

Hi,
 
The Script is very usefull! thanks.
 
Could you post the code to write back to AD as well?
 
When it writes back to the Active Directory, does it write back every cell in the excel sheet, or only the updated fields?
 
Thanks!
 
Rgds,
Ronny

Ok...here's the script for writing back to AD. (you MUST use my original extract script for this to work). -careful with this one, please read script notes in beginning of file.
 
I've spend an hour or so cleaning it up and wrote in some logging. (didn't have it before, and now I think better).  Also,  in my original script I just re-commited all AD values, (even if just 1 property changed), but now this script will ONLY change values to those that changed, (and log it too).
 
I'm really glad to see that this script was helpful to you.  (and hopefully this write-back will be more helpful too).

Please let me know your feedback and how it works for you.
 
-Eric
 

  ' WRITE AD Properties from EXCEL Spreadsheet v1
 ' Written By:  Eric Davis  (edavis6678@yahoo.com)
 ' Date: 3/7/2006
 ' PLEASE NOTE:  This will ONLY work if you use my latest "extract" from AD script (posted above - and it was recently updated).  (since the colummns need to be in correct spot)
 ' DISCLAIMER : WARNING!!!  THIS SCRIPT WRITES AND CHANGES DATA TO ACTIVE DIRECTORY!
 ' I WILL AND CAN NOT BE RESPONSIBLE IF THIS SCREWS UP YOUR DIRECTORY!  USE AT YOUR OWN RISK!!!
 ' (with that being said)
 ' I have done LOTS of testing on this script and I run it all the time at my company, but forewarned, 
 ' PLEASE use logging mode first before doing anything!
 ' Script Notes:
 ' This script will NOT change AD properties for the following fields: 
 ' SamAccountName, CN, Manager, AdsPath, LastLogin, Primary SMTP, or any additional email aliases.
 ' Be sure to change the 4 variables below to suit your needs.  
 ' boolCommitFlag must be set to 1 in order to actually write to AD. (this good for testing) - Default is set to LOG only
 ' Other Notes:
 ' If ANY row value that has the Adspath value blank, script will quit.
 ' The script will not change row 1 -- reserved for header row
 ' Script will ONLY change/commit values to AD that are different from spreadsheet - it IS case sensitive.  (and it will log change to txt file)
 ' Enjoy!
 ' START SCRIPT
 Option Explicit
 On Error Resume Next ' Didn't have time to write extensive AD error checking when reading properties, so I set this on.  The typical error occurred
      ' when trying to read an AD property that doesn't exist.  Sometime I'll clean this up, but for now, I put resume next on.
 Dim ObjUser, PathofFile, shtName, x, ObjE, ObjWB, OutFile, PathofLogFile
 Dim FirstName, ADFirstName, LastName, ADLastName
 Dim Initials, ADInitials, Descrip, ADDescrip
 Dim Office, ADOffice, Telephone, ADTelephone
 Dim Email, ADEmail, WebPage, ADWebPage
 Dim Addr1, ADAddr1, City, ADCity
 Dim State, ADState, ZipCode, ADZipCode
 Dim Title, ADTitle, Department, ADDepartment
 Dim Company, ADCompany, Profile, ADProfile
 Dim LoginScript, ADLoginScript, HomeDirectory, ADHomeDirectory, HomeDrive, ADHomeDrive
 Dim ret, boolCommitFlag, fso, ObjExcel, wb, ReadLine, boolWriteNeeded
 Set fso = CreateObject("Scripting.FileSystemObject")
 '###########################
 'CHANGE THIS VARIABLES HERE 
 '###########################
 PathofFile = "C:\ADoutput.xls"
 PathofLogFile = "C:\ADChange_log.txt"
 shtName = "Active Directory Users" ' sheet names must match.  (if you used my script before, it will work)
 boolCommitFlag = "0" ' IMPORTANT - CHANGE to 1 or it will only LOG what will be changed.
 '###########################
 '###########################
 If boolCommitFlag = 0 Then
  ret = MsgBox("Click OK to TEST Export from : " & PathofFile & vbcrlf & vbcrlf & "LOGFILE: " & PathofLogFile,1,"Welcome to AD Import (LOGGING ONLY)")
   If ret <> 1 Then WScript.quit
  Elseif boolCommitFlag = 1 Then
  ret = MsgBox("Click OK to WRITE changes from Import file : " & PathofFile & vbcrlf & vbcrlf & "LOGFILE: " & PathofLogFile,1,"Welcome to AD Import (WRITE MODE)")
 End If
 Err.clear
 Set OutFile = fso.openTextFile(PathofLogFile, 8, True, -2) ' will APPEND to EXISTING FILE
 If Err.Number <> 0 Then
  MsgBox "ERROR in OPENING LOG FILE (It's probably open) -  STOPPING SCRIPT",48, "NOPE - Ain't going to do it"
  WScript.Quit
 End If
 
 Call ExcelSetup() ' Sub to set-up Excel
 ' Begin header of log file
 If boolCommitFlag = 0 Then
  OutFile.Write vbcrlf & "STARTING LOG ONLY On " & Time() & vbcrlf
  Elseif boolCommitFlag = 1 then
  OutFile.Write vbcrlf & "STARTING AD WRITE On " & Time() & vbcrlf
 End If
 x = 1 ' Set to 1 so to not try the header row
 readLine = ObjWB.WorkSheets(shtName).Cells.Item(x,24).Value ' Read Header so it ain't nothing to start
 Do While ReadLine <> ""
  x = x + 1
  readLine = ObjWB.WorkSheets(shtName).Cells.Item(x,24).Value ' Read the ADSPath
  If ReadLine = "" Then Exit Do ' if blank, exit
  Set objUser = GetObject (ReadLine) ' Bind to AD Object
  
  ' Do Comparisons on all values and PUT values
  FirstName = ObjWB.WorkSheets(shtName).Cells.Item(x,4).Value
  ADFirstName = ObjUser.givenname
  If FirstName <> ADFirstName Then 
   Call LogFileWrite("FirstName (givenname)", FirstName, ADFirstName)
   If FirstName <> "" then ObjUser.Put "givenname", FirstName
  End If
  
  LastName = ObjWB.WorkSheets(shtName).Cells.Item(x,5).Value
  ADLastName = ObjUser.sn
  If LastName <> ADLastName Then
   Call LogFileWrite("LastName (sn)", LastName, ADLastName)
   If LastName <> "" Then ObjUser.Put "sn", LastName
  End If
  
  Initials = ObjWB.WorkSheets(shtName).Cells.Item(x,6).Value
  ADInitials = ObjUser.initials
  If Initials <> ADInitials Then
   Call LogFileWrite("Initials (initials)", Initials, ADInitials)
   If Initials <> "" Then ObjUser.Put "initials", Initials
  End If
  
  Descrip = ObjWB.WorkSheets(shtName).Cells.Item(x,7).Value
  ADDescrip = ObjUser.Description
  If Descrip <> ADDescrip Then
   Call LogFileWrite("Description (description)", Descrip, ADDescrip)
   If Descrip <> "" Then ObjUser.Put "description", Descrip
  End If
  
  Office = ObjWB.WorkSheets(shtName).Cells.Item(x,8).Value
  ADOffice = ObjUser.physicalDeliveryOfficeName
  If Office <> ADOffice Then
   Call LogFileWrite("Office (office)", Office, ADOffice)
   If Office <> "" Then ObjUser.Put "physicalDeliveryOfficeName", Office
  End If
  Telephone = ObjWB.WorkSheets(shtName).Cells.Item(x,9).Value
  ADTelephone = ObjUser.telephoneNumber
  If Telephone <> ADTelephone Then
   Call LogFileWrite("Telephone (telephonenumber)", Telephone, ADTelephone)
   If Telephone <> "" Then ObjUser.Put "telephoneNumber", Telephone
  End If
  
  Email = cstr(ObjWB.WorkSheets(shtName).Cells.Item(x,10).Value)
  ADEmail = ObjUser.mail
  If Email <> ADEmail Then
   Call LogFileWrite("Email (mail)", Email, ADEmail)
   If Email <> "" Then ObjUser.Put "mail", Email
  End If
  
  WebPage = ObjWB.WorkSheets(shtName).Cells.Item(x,11).Value
  ADWebPage = ObjUser.HomePage
  If WebPage <> ADWebPage Then
   Call LogFileWrite("WebPage (homepage)", WebPage, ADWebPage)
   If WebPage <> "" Then ObjUser.Put "HomePage", WebPage
  End If
  
  Addr1 = ObjWB.WorkSheets(shtName).Cells.Item(x,12).Value
  ADAddr1 = ObjUser.streetAddress
  If Addr1 <> ADAddr1 Then 
   Call LogFileWrite("Addr1 (streetAddress)", Addr1, ADAddr1)
   If Addr1 <> "" Then ObjUser.Put "streetAddress", Addr1
  End If
  City = ObjWB.WorkSheets(shtName).Cells.Item(x,13).Value
  ADCity = ObjUser.l
  If City <> ADCity Then 
   Call LogFileWrite("City (l)", City, ADCity)
   If City <> "" Then ObjUser.Put "l", City
  End If
  
  State = ObjWB.WorkSheets(shtName).Cells.Item(x,14).Value
  ADState = ObjUser.st
  If State <> ADState Then 
   Call LogFileWrite("State (st)", State, ADState)
   If State <> "" Then ObjUser.Put "st", State
  End If
  
  ZipCode = FormatNumber(ObjWB.WorkSheets(shtName).Cells.Item(x,15).Value,0,0,0,0)
  ADZipCode = ObjUser.Postalcode
  If ZipCode <> ADZipCode Then 
   Call LogFileWrite("ZipCode (postalcode)", ZipCode, ADZipeCode)
   If ZipCode <> "" Then ObjUser.Put "postalcode", ZipCode
  End If
  
  Title = ObjWB.WorkSheets(shtName).Cells.Item(x,16).Value
  ADTitle = ObjUser.Title
  If Title <> ADTitle Then 
   Call LogFileWrite("Title (Title)", Title, ADTitle)
   If Title <> "" Then ObjUser.Put "Title", Title
  End If
  
  Department = ObjWB.WorkSheets(shtName).Cells.Item(x,17).Value
  ADDepartment = ObjUser.Department
  If Department <> ADDepartment Then 
   Call LogFileWrite("Department (Department)", Department, ADDepartment)
   If Department <> "" Then ObjUser.Put "Department", Department
  End If
  Company = ObjWB.WorkSheets(shtName).Cells.Item(x,18).Value
  ADCompany = ObjUser.Company
  If Company <> ADCompany Then 
   Call LogFileWrite("Company (Company)", Company, ADCompany)
   If Company <> "" Then ObjUser.Put "Company", Company
  End If
  
  Profile = ObjWB.WorkSheets(shtName).Cells.Item(x,20).Value
  ADProfile = ObjUser.ProfilePath
  If Profile <> ADProfile Then 
   Call LogFileWrite("Profile (Profilepath)", Profile, ADProfile)
   If Profile <> "" Then ObjUser.Put "Profilepath", Profile
  End If
  
  LoginScript = ObjWB.WorkSheets(shtName).Cells.Item(x,21).Value
  ADLoginScript = ObjUser.ScriptPath
  If LoginScript <> ADLoginScript Then 
   Call LogFileWrite("LoginScript (Scriptpath)", LoginScript, ADLoginScript)
   If LoginScript <> "" Then ObjUser.Put "ScriptPath", LoginScript
  End If
  
  HomeDirectory = ObjWB.WorkSheets(shtName).Cells.Item(x,22).Value
  ADHomeDirectory = ObjUser.HomeDirectory
  If HomeDirectory <> ADHomeDirectory Then 
   Call LogFileWrite("HomeDirectory (HomeDirectory)", HomeDirectory, ADHomeDirectory)
   If LoginScript <> "" Then ObjUser.Put "HomeDirectory", HomeDirectory
  End If
  
  
  HomeDrive = ObjWB.WorkSheets(shtName).Cells.Item(x,23).Value
  ADHomeDrive = ObjUser.HomeDrive
  If HomeDrive <> ADHomeDrive Then 
   Call LogFileWrite("HomeDrive (HomeDrive)", HomeDrive, ADHomeDrive)
   If HomeDrive <> "" Then ObjUser.Put "HomeDrive", HomeDrive
  End If
  
  If boolCommitFlag = 1 and boolWriteNeeded = 1 then
   ObjUser.SetInfo
  End If
  
  
  Set ObjUser = Nothing
  FirstName = ""
  ADFirstName = ""
  LastName = ""
  ADLastName = ""
  Initials = ""
  ADInitials = ""
  Descrip = ""
  ADDescrip = ""
  Office = ""
  ADOffice = ""
  Telephone = ""
  ADTelephone = ""
  Email = ""
  ADEmail = ""
  WebPage = ""
  ADWebPage = ""
  Addr1 = ""
  ADAddr1 = ""
  City = ""
  ADCity = ""
  State = ""
  ADState = ""
  ZipCode = ""
  ADZipCode = ""
  Title = ""
  ADTitle = ""
  Department = ""
  ADDepartment = ""
  Company = ""
  ADCompany = ""
  Profile = ""
  ADProfile = ""
  LoginScript = ""
  ADLoginScript = ""
  HomeDirectory = ""
  ADHomeDirectory = ""
  HomeDrive = ""
  ADHomeDrive = ""
  boolWriteNeeded = 0
 Loop
 ObjWB.Close
 If boolCommitFlag = 0 Then
  OutFile.Write "Completed LOG ONLY On " & Time() & Date() & vbcrlf
  Elseif boolCommitFlag = 1 then
  OutFile.Write "Completed AD WRITE On " & Time() & Date() & vbcrlf
 End If
 OutFile.Close
 Set ObjExcel = Nothing
 Set fso = Nothing
 MsgBox "DONE"
 
 Sub LogFileWrite(FieldChanged, NewValue,ADValue)
 boolWriteNeeded = 1
 If ADValue = "" Then ADValue = "WasNothingBefore"
 If NewValue = "" Then NewValue = "WillBeBlankNow"
 OutFile.Writeline Date() & vbTab & ReadLine & vbTab & "CHANGED" & vbTab & FieldChanged & vbTab & ADValue & vbTab & NewValue
 'WScript.echo Date() & vbTab & ReadLine & vbTab & "CHANGED" & vbTab & FieldChanged & vbTab & ADValue & vbTab & NewValue  '(Put this line in, if you want cscript output)
 End Sub
 
 Sub ExcelSetup()
 Set objExcel = CreateObject("Excel.Application")
     Set wb = objExcel.WorkBooks
     Set objwb = wb.Open (PathofFile)
     objwb.Activate
 End Sub
 

IN Line 126 [Set objwb = objExcel.ActiveWorkbook.Worksheets(shtName)] I have a "Subscript out of range" error. Any ideas?

I'm not a pro of the excel object model, so my excel creation portion is probably prone to an error here or there..  I just ran the script from copying/pasting from forum to be sure it was copied up correctly and I didnt' receive error.  (seeing that I can't recreate, couple things come to mind.)
 
The script calls a sub to create the workbook, be sure line 7 is exactly as it is:  Call ExcelSetup("Sheet1")
 
This sub assumes that when you open Excel you have a default worksheet named, "Sheet1".  Verify this is the case for you by opening Excel and look at the sheet names.
 
The only thing thing that comes to mind is that the Excel object on your computer is not being created properly.  Can you try running this on another computer?
 
When you run the script and it gives an error, can you check your "task mananger" and see if EXCEL.EXE is running?
 
 
 
 
 

Nice Scripts, I have an question, i would like to export the ccmail field from AD do you know the object code i need to add to do this?

Thanks for any feed back.

I'm not familar with CCmail...can there only be 1 CCMAIL address?  or multiples

I can give you a quick fix to this, but I'm thinking of adding some more fields per other users' requests.

Give me a day or so.

ps - if you know VB, this is how i got the properties
 

     If Left(email,7) = "CCMAIL:" Then
   strCC = Mid(email,8)
    End If
    strCCSplit = Split(strCC," at ")
    strCCMailBox =strCCsplit(0)
    strCCPostOffice = strCCsplit(1)
 Next 
 

Thanks for the code i'll test it now.there can only be one ccmail for each user account. (i Believe!!!)

I've made some small formatting changes to make it easier to read. I added an autosave at the end as well.

 Dim ObjWb 
 Dim ObjExcel 
 Dim x, zz 
 Set objRoot = GetObject("LDAP://RootDSE") 
 strDNC = objRoot.Get("DefaultNamingContext") 
 Set objDomain = GetObject("LDAP://" & strDNC) ' Bind to the top of the Domain using LDAP using ROotDSE 
 Call ExcelSetup("Sheet1") ' Sub to make Excel Document 
 x = 1 
 Call enummembers(objDomain) 
 Sub enumMembers(objDomain) 
     On Error Resume Next 
     Dim Secondary(20) ' Variable to store the Array of 2ndary email alias's 
     For Each objMember In objDomain ' go through the collection     
         If ObjMember.Class = "user" Then ' if not User object, move on. 
             x = x +1 ' counter used to increment the cells in Excel 
             
               objwb.Cells(x, 1).Value = objMember.Class 
               ' I set AD properties to variables so if needed you could do Null checks or add if/then's to this code 
               ' this was done so the script could be modified easier. 
             SamAccountName = ObjMember.samAccountName 
             Cn = ObjMember.CN 
             FirstName = objMember.GivenName 
             LastName = objMember.sn 
             initials = objMember.initials 
             Descrip = objMember.description 
             Office = objMember.physicalDeliveryOfficeName 
             Telephone = objMember.telephonenumber 
             EmailAddr = objMember.mail 
             WebPage = objMember.wwwHomePage 
             Addr1 = objMember.streetAddress 
             City = objMember.l 
             State = objMember.st 
             ZipCode = objMember.postalCode 
             Title = ObjMember.Title 
             Department = objMember.Department 
             Company = objMember.Company 
             Manager = ObjMember.Manager 
             Profile = objMember.profilePath 
             LoginScript = objMember.scriptpath 
             HomeDirectory = ObjMember.HomeDirectory 
             HomeDrive = ObjMember.homeDrive 
             AdsPath = Objmember.Adspath 
             LastLogin = objMember.LastLogin 
             
             zz = 1 ' Counter for array of 2ndary email addresses 
             For Each email in ObjMember.proxyAddresses 
                If Left (email,5) = "SMTP:" Then 
             Primary = Mid (email,6) ' if SMTP is all caps, then it's the Primary 
                Elseif Left (email,5) = "smtp:" Then 
                   Secondary(zz) = Mid (email,6) ' load the list of 2ndary SMTP emails into Array. 
                   zz = zz + 1 
                End If 
             Next 
             ' Write the values to Excel, using the X counter to increment the rows. 
             
             objwb.Cells(x, 2).Value = SamAccountName 
             objwb.Cells(x, 3).Value = CN 
             objwb.Cells(x, 4).Value = FirstName 
             objwb.Cells(x, 5).Value = LastName 
             objwb.Cells(x, 6).Value = Initials 
             objwb.Cells(x, 7).Value = Descrip 
             objwb.Cells(x, 8).Value = Office 
             objwb.Cells(x, 9).Value = Telephone 
             objwb.Cells(x, 10).Value = EmailAddr
             objwb.Cells(x, 11).Value = WebPage 
             objwb.Cells(x, 12).Value = Addr1 
             objwb.Cells(x, 13).Value = City 
             objwb.Cells(x, 14).Value = State 
             objwb.Cells(x, 15).Value = ZipCode 
             objwb.Cells(x, 16).Value = Title 
             objwb.Cells(x, 17).Value = Department 
             objwb.Cells(x, 18).Value = Company 
             objwb.Cells(x, 19).Value = Manager 
             objwb.Cells(x, 20).Value = Profile 
             objwb.Cells(x, 21).Value = LoginScript 
             objwb.Cells(x, 22).Value = HomeDirectory 
             objwb.Cells(x, 23).Value = HomeDrive 
             objwb.Cells(x, 24).Value = Adspath 
             objwb.Cells(x, 25).Value = LastLogin 
             objwb.Cells(x,26).Value = Primary 
             
             ' Write out the Array for the 2ndary email addresses. 
             For ll = 1 To 20 
                 objwb.Cells(x,26+ll).Value = Secondary(ll) 
             Next 
             ' Blank out Variables in case the next object doesn't have a value for the property 
             SamAccountName = "-" 
             Cn = "-" 
             FirstName = "-" 
             LastName = "-" 
             initials = "-" 
             Descrip = "-" 
             Office = "-" 
             Telephone = "-" 
             EmailAddr = "-" 
             WebPage = "-" 
             Addr1 = "-" 
             City = "-" 
             State = "-" 
             ZipCode = "-" 
             Title = "-" 
             Department = "-" 
             Company = "-" 
             Manager = "-" 
             Profile = "-" 
             LoginScript = "-" 
             HomeDirectory = "-" 
             HomeDrive = "-" 
             Primary = "-" 
             For ll = 1 To 20 
                 Secondary(ll) = "" 
             Next 
         End If 
               
               ' If the AD enumeration runs into an OU object, call the Sub again to itinerate 
               
         If objMember.Class = "organizationalUnit" or OBjMember.Class = "container" Then 
             enumMembers (objMember) 
         End If 
     Next 
 End Sub 
 Sub ExcelSetup(shtName) ' This sub creates an Excel worksheet and adds Column heads to the 1st row 
     Set ObjExcel = CreateObject("Excel.Application") 
     Set objwb = objExcel.Workbooks.Add 
     Set objwb = objExcel.ActiveWorkbook.Worksheets(shtName) 
     Objwb.Name = "Active Directory Users" ' name the sheet 
     objwb.Activate 
     ObjExcel.Visible = True 
     objwb.Cells(1, 2).Value = "SamAccountName" 
     objwb.Cells(1, 3).Value = "CN" 
     objwb.Cells(1, 4).Value = "FirstName" 
     objwb.Cells(1, 5).Value = "LastName" 
     objwb.Cells(1, 6).Value = "Initials" 
     objwb.Cells(1, 7).Value = "Description" 
     objwb.Cells(1, 8).Value = "Office" 
     objwb.Cells(1, 9).Value = "Telephone" 
     objwb.Cells(1, 10).Value = "Email" 
     objwb.Cells(1, 11).Value = "WebPage" 
     objwb.Cells(1, 12).Value = "Addr1" 
     objwb.Cells(1, 13).Value = "City" 
     objwb.Cells(1, 14).Value = "State" 
     objwb.Cells(1, 15).Value = "ZipCode" 
     objwb.Cells(1, 16).Value = "Title" 
     objwb.Cells(1, 17).Value = "Department" 
     objwb.Cells(1, 18).Value = "Company" 
     objwb.Cells(1, 19).Value = "Manager" 
     objwb.Cells(1, 20).Value = "Profile" 
     objwb.Cells(1, 21).Value = "LoginScript" 
     objwb.Cells(1, 22).Value = "HomeDirectory" 
     objwb.Cells(1, 23).Value = "HomeDrive" 
     objwb.Cells(1, 24).Value = "Adspath" 
     objwb.Cells(1, 25).Value = "LastLogin" 
     objwb.Cells(1, 26).Value = "Primary SMTP"
     'formatting for header 
     Set objRange = objExcel.Range("A1","Z1")
     objRange.Interior.ColorIndex = 33
     objRange.Font.Bold = True
     objRange.Font.Underline = True
 End Sub 
 'autofit the output
 Set objRange = objwb.UsedRange
 objRange.EntireColumn.Autofit()
 ObjExcel.Save("ADoutput.xls")
 MsgBox "Done" ' show that script is complete 
 

oh..neat...i just tried it..very nice.
 
The clean-up is nice too.  I've been so slammed here at work, but I still have the code, (need to post it), which adds CCMAIL.  I'm also thinking of expanding the output for every AD property, and eventually also support over 1K users.  (the query just has to use a different provider).  Also want to add an option for computers too.  (which I already have written, again not cleaned up for publishing though).  (I even have another that does for local accounts - add and list, (a need that arose from creating a non-domain FTP server).  I'll post that sometime too  :)  (I know there are many free-ware scripts already written for this, but I think it's more fun to do it yourself)
 
Cheers

ORIGINAL: edavis6678

oh..neat...i just tried it..very nice.

Thanks, I got most of the formatting code from the script center. I've been wanting to play with the excel object and had a little time on Friday. :)

The clean-up is nice too.  I've been so slammed here at work, but I still have the code, (need to post it), which adds CCMAIL.  I'm also thinking of expanding the output for every AD property, and eventually also support over 1K users.  (the query just has to use a different provider).

Whenever you want to work on that I'd be interested in helping, although I can already see one problem. We have a custom AD schema here and a generic script that pulls all attributes might not work, so maybe pulling the schema first then enumerating all the attributes that way.

Also want to add an option for computers too.  (which I already have written, again not cleaned up for publishing though).  (I even have another that does for local accounts - add and list, (a need that arose from creating a non-domain FTP server).  I'll post that sometime too  :)  (I know there are many free-ware scripts already written for this, but I think it's more fun to do it yourself)

Again, I'd be happy to help implement doing computers rather than users as well.

Thanks for the excellent script!

Great job on the script. I was wondering if someone could help me modify this (your initial script).....
I would like it to return all of the users group memberships instead of the ADSPath.... for example
 
John    Doe
                         Domain User
                         Accounting
                         IT User
Jane Doe
                       Domain Users
                       Internet Access Group
                       Domain Administrator
etc......
 
I am trying to comply with SARBOX and this script is EXACTLY what I was looking for ... only I need the group memberships listed for each user......
Any help is greatly appreciated.
 
Here is the scirpt that you had posted and I had been modifying.......
 
Sub enumMembers(objDomain)
On Error Resume Next
Dim Secondary(20) ' Variable to store the Array of 2ndary email alias's
For Each objMember In objDomain ' go through the collection
If ObjMember.Class = "user" Then ' if not User object, move on.
x = x + 1 ' counter used to increment the cells in Excel
 
FirstName = objMember.GivenName
LastName = objMember.sn
Manager = ObjMember.Manager
AdsPath = Objmember.Adspath
 zz = 1 ' Counter for array of 2ndary email addresses
 For each email in ObjMember.proxyAddresses
   If Left (email,5) = "SMTP:" Then
 Primary = Mid (email,6) ' if SMTP is all caps, then it's the Primary
   ElseIf Left (email,5) = "smtp:" Then
     Secondary(zz) = Mid (email,6) ' load the list of 2ndary SMTP emails into Array.
      zz = zz + 1
  End If
Next
' Write the values to Excel, using the X counter to increment the rows.
objwb.Cells(x, 1).Value = FirstName
objwb.Cells(x, 2).Value = LastName
objwb.Cells(x, 3).Value = Manager
objwb.Cells(x, 4).Value = ADSPath
' Write out the Array for the 2ndary email addresses.
For ll = 1 To 20
objwb.Cells(x,26+ll).Value = Secondary(ll)
Next
' Blank out Variables in case the next object doesn't have a value for the property
FirstName = "-"
LastName = "-"
Manager = "-"
For ll = 1 To 20
Secondary(ll) = ""
Next
  End If
 
  ' If the AD enumeration runs into an OU object, call the Sub again to itinerate
 
  If objMember.Class = "organizationalUnit" or OBjMember.Class = "container" Then
      enumMembers (objMember)
  End If
Next
End Sub
Sub ExcelSetup(shtName) ' This sub creates an Excel worksheet and adds Column heads to the 1st row
Set objExcel = CreateObject("Excel.Application")
Set objwb = objExcel.Workbooks.Add
Set objwb = objExcel.ActiveWorkbook.Worksheets(shtName)
Objwb.Name = "Active Directory Users" ' name the sheet
objwb.Activate
objExcel.Visible = True
objwb.Cells(1, 1).Value = "FirstName"
objwb.Cells(1, 2).Value = "LastName"
objwb.Cells(1, 3).Value = "Manager"
objwb.Cells(1, 4).Value = "Adspath"
End Sub
MsgBox "Done" ' show that script is complete

Removed and reposted in better location

That was EXATLY what I was looking for! I can't thank you enough...... I wonder if I could get you to tell me 1 thing.... how would I add attributes from ad and include them into the database? I would like to pull the display name, group description, and manager attributes into the database as well if possible. That would give me everything I need.... Thanks again.... it has really helped me out.....

Very nice to hear that this working for.  It's nice to know that someone can find a script I find useful also useful.

As for other properties, it's pretty straight forward.  Below are some common properties.

SamAccountName = ObjMember.samAccountName
Cn = ObjMember.CN
FirstName = objMember.GivenName
LastName = objMember.sn
initials = objMember.initials
Descrip = objMember.description
Office = objMember.physicalDeliveryOfficeName
Telephone = objMember.telephonenumber
EmailAddr = objMember.mail
WebPage = objMember.wwwHomePage
Addr1 = objMember.streetAddress
City = objMember.l
State = objMember.st
ZipCode = objMember.postalCode
Title = ObjMember.Title
Department = objMember.Department
Company = objMember.Company
Manager = ObjMember.Manager
Profile = objMember.profilePath
LoginScript = objMember.scriptpath
HomeDirectory = ObjMember.HomeDirectory
HomeDrive = ObjMember.homeDrive
AdsPath = Objmember.Adspath
LastLogin = objMember.LastLogin


Here is a link from MS on the rest of them:  http://windowssdk.msdn.microsoft.com/library/default.asp?url=/library/en-us/ADSI/adsi/iadsuser.asp

Remember that some values are very long and some have values that don't insert well into Access unless you tweak them.  (That's why i have the FixValue function in my script).  Also, some values are COLLECTIONS, (so you have to write a routine to get it out).

I'm not on a domain atm, so I can't test these changes, if what I posted here doesn't work, let me know and I'll correct, but below is what you need to change.

If you want to change the properties, or add more, just simply add more colummns to your database table, set variables to the user object properties, then modify the INSERT command with the additional properties.

For example....

If you want to ADD another columm for Manager ADS path, modify the script this way:  (RED notes new lines)

First, you must add a colummn to your table and name it, ManagerADSPath.  Make it a MEMO type since it will return a very long value.

Next, add a variable named, ManagerADS = to the AD user object property.  Shown below.  (also note I purposely named it differently so you can see how the INSERT command works)


ADGroupName = Mid(FixValue(objADGroup.Name),4)
SamAccountName = FixValue(objMember.SamAccountName)
Department = FixValue(ObjMember.Department)
UserADSPath = FixValue(objMember.AdsPath)
   ManagerADS = FixValue(objMember.Manager)
qryInsert = "INSERT INTO [" & dbTableName & "](ADGroupName, SamAccountName, Department,CN, UserAdsPath, ManagerADSPath) VALUES ('" & ADGroupName & "','" & SamAccountName & "','" & Department & "', '" & CN & "', '" & UserAdsPath & "', '" & ManagerADS & '")"
conn.Execute (qryInsert)

Just add more and more if you want, or change some of them with what you want.

Special note.  Manager for a user object only returns an ADSPath.

Another thing you can do.  Take the excel output from the original script and IMPORT it into Access, then join the tables VIA a key field.  (like SamAccountName), and make your own report, query, etc....(you could also get the Display name of the manager, but simply buidling a query and linking ADSPATH)

Hope this makes sense

heres one to html
' DocumentGroups.vbs
' VBScript program to document all groups in Active Directory.
' Outputs group name, type of group, all members, and types of member.
' Lists all groups that are members, but does not list the nested group
' membership.
'----------------------------------------------------------------------
' Copyright (c) 2002 Richard L. Mueller
' Hilltop Lab web site - http://www.rlmueller.net
' Version 1.0 - November 10, 2002
' Version 1.1 - February 19, 2003 - Standardize Hungarian notation.
' Version 1.2 - March 11, 2003 - Remove SearchScope property.

' *** MODIFIED March 13, 2006 - Added HTML File Out, Addtional Group/User Properties
'
' This script is designed to be run at a command prompt, using the
' Cscript host. The output can be redirected to a text file.
' For example:
' cscript //nologo DocumentGroups.vbs > groups.txt
'
' You have a royalty-free right to use, modify, reproduce, and
' distribute this script file in any way you find useful, provided that
' you agree that the copyright owner above has no warranty,obligations,
' or liability for such use.

Option Explicit

Dim objConnection, objCommand, objRootDSE, strDNSDomain, strQuery
Dim objRecordSet, strDN, objGroup
Dim FileSystem, oFile
' Open Text File for Output
Set FileSystem = WScript.CreateObject("Scripting.FileSystemObject")
Set oFile = FileSystem.CreateTextFile("GroupMemebrshipNew.html", True)

oFile.writeLine "<HTML><HEAD><TITLE>Group Membership for MyDomain.com</TITLE><HEAD><BODY>"
oFile.writeLine "<h4><TABLE width=100% border=0 padding=0 cellspacing=0 valign=top>"


' Use ADO to search Active Directory.
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")

' Search for all groups, return the Distinguished Name of each.
strQuery = "<LDAP://" & strDNSDomain _
& ">;(objectClass=group);distinguishedName;subtree"
objCommand.CommandText = strQuery
objCommand.Properties("Page Size") = 100
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False

Set objRecordSet = objCommand.Execute
If objRecordSet.EOF Then
Wscript.Echo "No groups found"
objConnection.Close
Set objRootDSE = Nothing
Set objConnection = Nothing
Set objCommand = Nothing
Set objRecordSet = Nothing
Wscript.Quit
End If

' Enumerate all groups, bind to each, and document group members.
Do Until objRecordSet.EOF
strDN = objRecordSet.Fields("distinguishedName")
Set objGroup = GetObject("LDAP://" & strDN)

' OUTPUT
oFile.writeLine "<TR>"
oFile.writeLine "<TD width=20% valign=top bgcolor=black><font color=white><strong><u>" & "Group Name:" &_
"</u></strong></font></TD><TD width=80% valign=top><strong>" &_
objGroup.SAMaccountName & "</strong></TD>"
oFile.writeLine "</TR><TR>"
oFile.writeLine "<TD valign=top bgcolor=black><font color=white><strong><u>" & "Distinguished Name:" &_
"</u></strong></font></TD><TD valign=top><strong>" &_
objGroup.distinguishedName & "</strong></TD>"
oFile.writeLine "</TR><TR>"
oFile.writeLine "<TD valign=top bgcolor=black><font color=white><strong><u>" & "Description:" &_
"</u></strong></font></TD><TD valign=top><strong>" &_
objGroup.description & "</strong></TD>"
oFile.writeLine "</TR><TR>"
oFile.writeLine "<TD valign=top bgcolor=black><font color=white><strong><u>" & "Type:" & "</u></strong></font></TD><TD valign=top><strong>" & GetType(objGroup.groupType) & "</strong></TD>"
oFile.writeLine "</TR>"

oFile.writeLine "<TR><TD valign=top bgcolor=black><font color=white><strong><u>Members:</font></TD><TD align=left valign=top>"
oFile.writeLine "<TABLE width=70% border=0 cellspacing=0 cellpadding=0>"
oFile.writeLine "<Tr>"
oFile.writeLine " <TD valign=top><strong><u> Name </u></strong></TD>"
oFile.writeLine " <TD valign=top><strong><u> Account </u></strong></TD>"
oFile.writeLine " <TD valign=top><strong><u> Type </u></strong></TD>"
oFile.writeLine "</Tr>"
Call GetMembers(objGroup)
oFile.writeLine "</TABLE>"

oFile.writeLine "</TD></TR>"

oFile.writeLine "<TR><TD COLSPAN=2><hr width=90%></TD></TR>"


objRecordSet.MoveNext

Loop
oFile.writeLine "</TABLE></BODY></HTML>"

msgBox "Done !!!"

' Clean up.
objConnection.Close
Set objRootDSE = Nothing
Set objGroup = Nothing
Set objConnection = Nothing
Set objCommand = Nothing
Set objRecordSet = Nothing

Function GetType(intType)
' Function to determine group type from the GroupType attribute.
If (intType And &h01) <> 0 Then
GetType = "Built-in"
ElseIf (intType And &h02) <> 0 Then
GetType = "Global"
ElseIf (intType And &h04) <> 0 Then
GetType = "Local"
ElseIf (intType And &h08) <> 0 Then
GetType = "Universal"
End If
If (intType And &h80000000) <> 0 Then
GetType = GetType & "/Security"
Else
GetType = GetType & "/Distribution"
End If
End Function

Sub GetMembers(objADObject)
' Subroutine to document group membership.
' Members can be users or groups.
Dim objMember, strType
For Each objMember In objADObject.Members
If UCase(Left(objMember.objectCategory, 8)) = "CN=GROUP" Then
strType = "Group"
Else
strType = "User"
End If

' OUTPUT

oFile.writeLine "<TR>"
oFile.writeLine "<TD valign=top>" & objMember.displayName & _
"</TD><TD valign=top>" & objMember.SAMaccountName & _
"</TD><TD valign=top>" & strType & "</TD>"
oFile.writeLine "</TR>"
' Wscript.Echo " Member: " & objMember.sAMAccountName & " (" & strType & ")"
Next
Set objMember = Nothing
End Sub

I kepp getting a compile error when I run this...also, I can't find anything on the syntax to pull the group description...any ideas? Thanks.

I have tried it and it runs fine.
Have you saved it as .vbs file.
Are you administrator