List of email addresses including all aliases in Active Directory

Hey there!

I have found a nice vb script that will extract the email addresses for my active directory users.

However I need to extract ALL addresses, including aliases.

I'm trying to clean up my spam filter system that was not properly configured, and I need to delete about 500 users from it, and it would be handy to have a all-inclusive list of all email addresses and aliases to work from.  This is going to take a long time as it is, and without a list to work from it will take too long.

Attached is the script that will produce a list of the main email addresses for the users, and it works great, but it is not exactly what I need.  This script is already posted, but I am including it here for the people that find this post in a search engine, who's needs are met by this script.


Thanks!
George

'===========================================
'* Enter the DN of the container you want to base your 
'* search in, excluding the domain name (dc=domain,dc=com),
'* between the double quotes below. If you want it to
'* search the root leave it blank.
 
strContainer = "" 
 
 
strDirectory = "c:\work"
strFile = "UserEmailAddr.txt"
strOutput = strDirectory & strFile
 
 
'------ Check or Create csv file -------
 
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
 
' Check that the strDirectory folder exists
If objFSO.FolderExists(strDirectory) Then
   Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
WScript.Echo "Just created " & strDirectory
End If
 
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
Wscript.Echo "Just created " & strDirectory & strFile
End If 
 
set objFolder = nothing
set objFile = nothing
 
If err.number = vbEmpty then
Set objShell = CreateObject("WScript.Shell")
objShell.run ("Explorer" & " " & strDirectory)
Else WScript.echo "VBScript Error: " & err.number
End If
 
 
'---------- Write to file -----------
 
Set objRootDSE = GetObject("LDAP://rootDSE")
 
If strContainer = "" Then
    strADsPath = objRootDSE.Get("defaultNamingContext")
Else
    strADsPath = strContainer & "," & objRootDSE.Get("defaultNamingContext")
End If
 
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
 
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
 
 
'--- change the DN to where you want to start your search ---
objCommand.CommandText = _
    "<LDAP://" & strADsPath & ">;" & _
        "(objectCategory=User)" & _
        ";distinguishedName,name,mail;subtree"
 
Set objRecordSet = objCommand.Execute
set fso = createobject("scripting.filesystemobject")
 
Set objFile = FSO.OpenTextFile(strOutput, 8) 
objFile.WriteLine "Username" & vbTab & "Email Address" & vbTab & "Distinguished Name"
objFile.Close
 
While Not objRecordSet.EOF
 
    Set objFile = FSO.OpenTextFile(strOutput, 8) 
    objFile.WriteLine objRecordSet.Fields("Name") & vbTab & _
                      objRecordSet.Fields("Mail") & vbTab & _
                      objRecordSet.Fields("distinguishedName")
    objFile.Close
    objRecordSet.MoveNext
 
Wend
 
objConnection.Close
'===============================================

Select allOpen in new window