Esportare gli utenti dell’active directory in .csv o in Excel


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"