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("Foglio1") ' 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 Fax = objMember.facsimileTelephoneNumber 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 = Fax 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 = "-" Fax = "-" 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 = "Fax" 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 "Fatto!" ' show that script is complete
OPPURE
OPTION EXPLICIT dim FileName, multivaluedsep,strAttributes dim strFilter, strRoot, strScope dim cmd, rs,cn dim objRoot, objFSO,objCSV dim comma, q, i, j, mvsep, strAttribute, strValue ' ********************* Setup ********************* ' The filename of the csv file produced by this script FileName ="userexport.csv" ' Seperator used for multi-valued attributes multivaluedsep = ";" ' comma seperated list of attributes to export strAttributes = "GivenName,sn,initials,description,physicalDeliveryOfficeName,telephonenumber,mail,facsimileTelephoneNumber,streetAddress,l,st,postalCode,Title,Department,Company,Manager,profilePath,scriptpath,HomeDirectory,homeDrive,Adspath" ' Default filter for all user accounts (ammend if required) strFilter = "(&(objectCategory=person)(objectClass=user))" ' scope of search (default is subtree - search all child OUs) strScope = "subtree" ' search root. e.g. ou=MyUsers,dc=wisesoft,dc=co,dc=uk ' leave blank to search from domain root strRoot = "" ' ************************************************* q = """" set cmd = createobject("ADODB.Command") set cn = createobject("ADODB.Connection") set rs = createobject("ADODB.Recordset") cn.open "Provider=ADsDSOObject;" cmd.activeconnection = cn if strRoot = "" then set objRoot = getobject("LDAP://RootDSE") strRoot = objRoot.get("defaultNamingContext") end if cmd.commandtext = "<LDAP://" & strRoot & ">;" & strFilter & ";" & _ strAttributes & ";" & strScope '**** Bypass 1000 record limitation **** cmd.properties("page size")=1000 set rs = cmd.execute set objFSO = createobject("Scripting.FileSystemObject") set objCSV = objFSO.createtextfile(FileName) comma = "" ' first column does not require a preceding comma i = ' create a header row and count the number of attributes for each strAttribute in SPLIT(strAttributes,",") objcsv.write(comma & q & strAttribute & q) comma = "," ' all columns apart from the first column require a preceding comma i = i + 1 next ' for each item returned by the Active Directory query while rs.eof <> true and rs.bof <> true comma="" ' first column does not require a preceding comma objcsv.writeline ' Start a new line ' For each column in the result set for j = to (i - 1) select case typename(rs(j).value) case "Null" ' handle null value objcsv.write(comma & q & q) case "Variant()" ' multi-valued attribute ' Multi-valued attributes will be seperated by value specified in ' "multivaluedsep" variable mvsep = "" 'No seperator required for first value objcsv.write(comma & q) for each strValue in rs(j).Value ' Write value ' single double quotes " are replaced by double double quotes "" objcsv.write(mvsep & replace(strValue,q,q & q)) mvsep = multivaluedsep ' seperator used when more than one value returned next objcsv.write(q) case else ' Write value ' single double quotes " are replaced by double double quotes "" objcsv.write(comma & q & replace(rs(j).value,q,q & q) & q) end select comma = "," ' all columns apart from the first column require a preceding comma next rs.movenext wend ' Close csv file and ADO connection cn.close objCSV.Close wscript.echo "Finished"