VisualBasicSript Get User attributes into excel sheet - completing

Hi,

with this VBS below i'm getting the attributes of all user in AD into excel sheet

What i exactly want:

1. Expand the query for Mailbox Database (e.g. DB001) and the Exchange_Server on which the DB is mounted -  if it also possible for Exchange 2003 User and all Mail and sip adresses
the user has.

2.Not query for all user instead query for all User only, which i want to query (with name, or samaccountname as input)  Popup possible with input of different user comma separate
like  Z123456,Z123457,Z1234568

Thank you so much

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("Tabelle1") ' 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
        Descrip = objMember.Description
        Office = objMember.physicalDeliveryOfficeName
        Telephone = objMember.telephonenumber
        EmailAddr = objMember.mail
        Addr1 = objMember.streetAddress
        City = objMember.l
        State = objMember.st
        ZipCode = objMember.postalCode
        Department = objMember.Department
        Company = objMember.Company
        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 = Descrip
        ObjWb.Cells(x, 7).Value = Office
        ObjWb.Cells(x, 8).Value = Telephone
        ObjWb.Cells(x, 9).Value = EmailAddr
        ObjWb.Cells(x, 10).Value = Addr1
        ObjWb.Cells(x, 11).Value = City
        ObjWb.Cells(x, 12).Value = State
        ObjWb.Cells(x, 13).Value = ZipCode
        ObjWb.Cells(x, 14).Value = Department
        ObjWb.Cells(x, 15).Value = Company
        ObjWb.Cells(x, 16).Value = LastLogin
        ObjWb.Cells(x, 17).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 = "-"
        Descrip = "-"
        Office = "-"
        Telephone = "-"
        EmailAddr = "-"
        Addr1 = "-"
        City = "-"
        State = "-"
        ZipCode = "-"
        Department = "-"
        Company = "-"
        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

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 = "Descrip"
    ObjWb.Cells(1, 7).Value = "Office"
    ObjWb.Cells(1, 8).Value = "Telephone"
    ObjWb.Cells(1, 9).Value = "Email"
    ObjWb.Cells(1, 10).Value = "Addr1"
    ObjWb.Cells(1, 11).Value = "City"
    ObjWb.Cells(1, 12).Value = "State"
    ObjWb.Cells(1, 13).Value = "ZipCode"
    ObjWb.Cells(1, 14).Value = "Department"
    ObjWb.Cells(1, 15).Value = "Company"
    ObjWb.Cells(1, 16).Value = "LastLogin"
    ObjWb.Cells(1, 17).Value = "Primary SMTP"
End Sub
MsgBox "Done" ' show that script is complete

Select allOpen in new window