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")     '建立 Excel 活頁簿
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
           ExtPhone = objMember.otherTelephone
           FAX = objMember.FaxNumber
           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 = ExtPhone
           objwb.Cells(x, 11).Value = FAX
           objwb.Cells(x, 12).Value = EmailAddr
           objwb.Cells(x, 13).Value = WebPage
           objwb.Cells(x, 14).Value = Addr1
           objwb.Cells(x, 15).Value = City
           objwb.Cells(x, 16).Value = State
           objwb.Cells(x, 17).Value = ZipCode
           objwb.Cells(x, 18).Value = Title
           objwb.Cells(x, 19).Value = Department
           objwb.Cells(x, 20).Value = Company
           objwb.Cells(x, 21).Value = Manager
           objwb.Cells(x, 22).Value = Profile
           objwb.Cells(x, 23).Value = LoginScript
           objwb.Cells(x, 24).Value = HomeDirectory
           objwb.Cells(x, 25).Value = HomeDrive
           objwb.Cells(x, 26).Value = Adspath
           objwb.Cells(x, 27).Value = LastLogin
           objwb.Cells(x, 28).Value = Primary
           
           ' Write out the Array for the 2ndary email addresses.
           For ll = 1 To 20
               objwb.Cells(x,28+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 = "-"
           ExtPhone = "-"
           FAX = "-"
           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 = "AD使用者"       '活頁簿名稱
   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 = "Ext Phone"             '電話號碼-分機
   objwb.Cells(1, 11).Value = "FAX"                   '傳真號碼
   objwb.Cells(1, 12).Value = "Email"                 '電子郵件
   objwb.Cells(1, 13).Value = "WebPage"               '網頁
   objwb.Cells(1, 14).Value = "Addr1"                 '街道
   objwb.Cells(1, 15).Value = "City"                  '縣/市
   objwb.Cells(1, 16).Value = "State"                 '省份
   objwb.Cells(1, 17).Value = "ZipCode"               '郵遞區號
   objwb.Cells(1, 18).Value = "Title"                 '職稱
   objwb.Cells(1, 19).Value = "Department"            '部門
   objwb.Cells(1, 20).Value = "Company"               '公司
   objwb.Cells(1, 21).Value = "Manager"               '主管
   objwb.Cells(1, 22).Value = "Profile"               '使用者設定檔-設定檔路徑
   objwb.Cells(1, 23).Value = "LoginScript"           '使用者設定檔-登入指令檔
   objwb.Cells(1, 24).Value = "HomeDirectory"         '主資料夾-連線目錄路徑
   objwb.Cells(1, 25).Value = "HomeDrive"             '主資料夾-連線磁碟名稱
   objwb.Cells(1, 26).Value = "Adspath"               '
   objwb.Cells(1, 27).Value = "LastLogin"             '最後登入時間
   objwb.Cells(1, 28).Value = "Primary SMTP"          '主要電子郵件 Exchange Server
   objwb.Cells(1, 29).Value = "Secondary SMTP"        '次要電子郵件 Exchange Server
   'formatting for header
   Set objRange = objExcel.Range("A1","AC1")
   objRange.Interior.ColorIndex = 40
   objRange.Font.Bold = True
   'objRange.Font.Underline = True
End Sub
'autofit the output
Set objRange = objwb.UsedRange
objRange.EntireColumn.Autofit()

MsgBox "AD資料收集完成"