Submitted By: Michael Maher

Creates mail-enabled distribution lists based on information read from a text file.

Visual Basic
Edit|Remove
' Michael Maher 14/6/07
' Creation of mail enabled Distribution Lists from a text file.
' Must be run on a host with Exchange Server version of the Active Directory Users and Computers


    ' Input Boxes 
    strGroup = InputBox ("Input Group Name")
    strEmail = InputBox ("Input Group Email Address leaving out the suffix - @company.com")
    strFile = InputBox ("Input Location of a text file containing users") 

' -------------------------------------------------------------------------------------------------- 
    ' Determine LDAP Domain Name
    Set objRootDSE = GetObject("LDAP://RootDSE") 
    strDNSDomain = objRootDSE.Get("defaultNamingContext")

' --------------------------------------------------------------------------------------------------

    ' Create the (Universal) distribution group 
    Const ADS_GROUP_TYPE_UNIVERSAL_GROUP = &h8    
    Set objOU = GetObject("LDAP://ou=DLs,ou=Exchange Recipients," & strDNSDomain)
    Set objGroup = objOU.Create("Group", "cn=" & (strGroup)) 
    objGroup.Put "sAMAccountName", CStr(strGroup)
    objGroup.Put "groupType", ADS_GROUP_TYPE_UNIVERSAL_GROUP
    objGroup.Put "Name", CStr(strGroup)
    objGroup.Put "DisplayName", CStr(strGroup) 
'*** Hardcoded Admin Group ***
    ' Check an existing address in Active Directory to view your own legacy name
    objGroup.Put "legacyExchangeDN", "/o=EXCHANGE/ou=IE/cn=Recipients/cn=" & strGroup 
    objGroup.Put "mail", CStr(strEmail)
    objGroup.Put "mailNickname", CStr(strGroup)
    ' x400 Address required but can be set to anything if you are not actually using this addressing 
    objGroup.Put "proxyAddresses", Array ("X400:c=IE;a=;p=EXCHANGE;o=IE;s=" & 
        strEmail, "SMTP:" & CStr(strEmail) & "@company.com")
    objGroup.put "targetAddress", "SMTP:" & strEmail
    objGroup.SetInfo  

' --------------------------------------------------------------------------------------------------    

    ' Read the specified text file

    Dim oFSO, oTS
    Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
    
    On Error Resume Next
    Set oTS = oFSO.OpenTextFile (strFile)
        
        If Err <> 0 Then
            MsgBox "Couldn't open input file." 
            WScript.Quit
        End If

    On Error Goto 0
    Dim strMember
        Do Until oTS.AtEndOfStream 
        ' strMember is variable used for each user in text file
        strMember = oTS.ReadLine  
        If strMember <> "" Then   
            On Error Resume Next

            ' Use ADO to search Active Directory.
            Set adoCommand = CreateObject("ADODB.Command")
            Set adoConnection = CreateObject("ADODB.Connection")
             adoConnection.Provider = "ADsDSOObject"
            adoConnection.Open "Active Directory Provider"
            adoCommand.ActiveConnection = adoConnection
        
            ' Bind to Domain through alias RootDSE 
            strBase = "<LDAP://" & strDNSDomain & ">"

            ' Get x500 Distingushed Name of each strMember
            strFilter = "(&(samaccountname=" & strMember & "))" 
            strAttributes = "distinguishedName"
            strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
            adoCommand.CommandText = strQuery
            adoCommand.Properties("Page Size") = 100
            adoCommand.Properties("Timeout") = 30
            adoCommand.Properties("Cache Results") = False
            Set adoRecordset = adoCommand.Execute
        
                If (adoRecordset.EOF = True) Then
                    Wscript.Echo "No duplicate display names found"
                    Wscript.Quit
                End If 
        
            strDN = adoRecordset.Fields("distinguishedName")
            
            Const ADS_PROPERTY_APPEND = 3 
            Set objGroup = GetObject("LDAP://cn=" & strGroup & ",ou=DLs,ou=Exchange Recipients" & 
                strDNSDomain) 
' *** Hardcoded Mail Server ***            
            objGroup.add "LDAP://MAILSERVER001/" & strDN
            objGroup.SetInfo  
                                                    
            On Error Goto 0       
        End If
        Loop
            oTS.Close
            
    ' Cleanup Memory

    Set oTS = Nothing
    Set objGroup = Nothing
    Set strMember = Nothing
    Set strMail = Nothing 
    Set strFile = Nothing
    Set strGroup = Nothing