Populate Email Address Based On OU 2

[TravTrav]

Hello all,

Here is what I want to do. When I create a user in a specific OU, based on what that OU is, I would like it to populate what that persons email domain is. For instance, lets say I had an OU named ACME Accounting. I would like every account created in that OU to automatically get the email address X.X@acmeaccounting.com. Does anyone know if this is something that can be done?

Thanks,
Trav

 

[SpideySMJ]

I wouldn't mind trying to do this as well. I tried using the recipient policies to look at the OU but it never seemed to work for me.

"I reject your reality and substitute one of my own.

 

[TravTrav]

Well, you definitely cannot base your recipient policy on OU's...per MS...

http://support.microsoft.com/?kbid=296112

 

[Xanaxo]

Thats right. You cannot use an OU. I recommend using a custom attribute. You can bulk import a custom attribute using ADModify to make this easier on you.

Steven Parent [MSFT]

 

[markdmac]

This is easy enough to do with vbscript.
You will first want a list of all users from the domain:

'==========================================================================
'
'
' NAME: <GetExistingUsers.vbs>
'
' AUTHOR: Mark D. MacLachlan , The Spiders Parlor
' DATE  : 4/24/2003
'
' COMMENT: Returns list of AD users for a Domain.  Saves to users.txt.
'
'==========================================================================

  Dim TheDomain, User, strDomain

  CONST forReading = 1
  CONST forWriting = 2
  CONST forAppending = 8

  Set fso= createObject("scripting.fileSystemObject")
  fso.CreateTextFile("users.txt")

  Set file=fso.GetFile("users.txt")
  Set myfile=file.OpenAsTextStream(forAppending)



     'Accept the Domain name
     strDomain = inputbox("Enter Domain Name")

     'Use the WinNT Directory Services
     strDomain = "WinNT://" & strDomain

    'Create the Domain object
     Set TheDomain = GetObject(strDomain)

    'Search for Computers in the Domain
     TheDomain.Filter = Array("User")

     listTxt= ""

     For Each User In TheDomain
       listTxt= listTXT & User.Name & vbCrLf
     Next 

     myfile.write listTxt
     

    'Clean up
     Set User = Nothing
     Set TheDomain = Nothing

You will then want to go through each user in the list, find their OU and append the SMTP address.

'==========================================================================
'
' NAME: AppendSMTPbasedonUSerOU.vbs
'
' AUTHOR: Mark D. MacLachlan , The Spider's Parlor
' URL: [URL unfurl="true"]http://www.thespidersparlor.com[/URL]
' DATE  : 7/26/2005
'
' COMMENT: Thanks go out to Tek-Tips user K0b3 for the
'          SearchDistinguishedName function.
'
'==========================================================================



On Error Resume Next

'open the file system object
Set oFSO = CreateObject("Scripting.FileSystemObject")
set WSHShell = wscript.createObject("wscript.shell")
'open the data file
Set oTextStream = oFSO.OpenTextFile("user.txt")
'make an array from the data file
UsersList = Split(oTextStream.ReadAll, vbNewLine)
'close the data file
oTextStream.Close

For Each UserString In UsersList
		'First grab the DistinguishedName
		UserDN = SearchDistinguishedName(UserString)
		'Now bind to the user object
		Set UserObj = GetObject("LDAP://" & UserDN)
		'Find the Relative Distinguished Name (RDN)
		UserRDN = UserObj.Name
		'Subtract the length of the RDN plus 4 more for the comma OU=
		'You now have the full path to the users OU
		FullOU = Right(UserDN,Len(UserDN)-Len(UserRDN)-4)
		'Now split the OU on the comma to get the users OU.
		OUArray = Split(FullOU,",")
		UserOU= OUArray(0)
		
		'Finally now we can append an SMTP address.
		    Set objRecip = UserObj
		    sAddress = "smtp:" & UserString & "@" & UserOU& ".companyname.com"
		    bIsFound = False
		    vProxyAddresses = objRecip.ProxyAddresses
		    nProxyAddresses = UBound(vProxyAddresses)
		    i = 0
		    Do While i <= nProxyAddresses
		          If vProxyAddresses(i) = sAddress  Then
		             bIsFound = True
		                Exit Do
		          End If
		          i = i + 1
		    Loop
		    If Not bIsFound Then
		           ReDim Preserve vProxyAddresses(nProxyAddresses + 1)
		           vProxyAddresses(nProxyAddresses + 1) = sAddress
		           objRecip.ProxyAddresses = vProxyAddresses
		           oUser.SetInfo
		    End If
Next		


Public Function SearchDistinguishedName(ByVal vSAN)
    ' Function:     SearchDistinguishedName
    ' Description:  Searches the DistinguishedName for a given SamAccountName
    ' Parameters:   ByVal vSAN - The SamAccountName to search
    ' Returns:      The DistinguishedName Name
    Dim oRootDSE, oConnection, oCommand, oRecordSet

    Set oRootDSE = GetObject("LDAP://rootDSE")
    Set oConnection = CreateObject("ADODB.Connection")
    oConnection.Open "Provider=ADsDSOObject;"
    Set oCommand = CreateObject("ADODB.Command")
    oCommand.ActiveConnection = oConnection
    oCommand.CommandText = "<LDAP://" & oRootDSE.get("defaultNamingContext") & _
        ">;(&(objectCategory=User)(samAccountName=" & vSAN & "));distinguishedName;subtree"
    Set oRecordSet = oCommand.Execute
    On Error Resume Next
    SearchDistinguishedName = oRecordSet.Fields("DistinguishedName")
    On Error GoTo 0
    oConnection.Close
    Set oRecordSet = Nothing
    Set oCommand = Nothing
    Set oConnection = Nothing
    Set oRootDSE = Nothing
End Function

If you want to append the new address as the primary SMTP then you will need to do it a little differently:

'==========================================================================
'
' NAME: AppendSMTPbasedonUSerOUPrimaryAddress.vbs
'
' AUTHOR: Mark D. MacLachlan , The Spider's Parlor
' URL: [URL unfurl="true"]http://www.thespidersparlor.com[/URL]
' DATE  : 7/26/2005
'
' COMMENT: Thanks go out to Tek-Tips user K0b3 for the
'          SearchDistinguishedName function.
'
'==========================================================================



On Error Resume Next

'open the file system object
Set oFSO = CreateObject("Scripting.FileSystemObject")
set WSHShell = wscript.createObject("wscript.shell")
'open the data file
Set oTextStream = oFSO.OpenTextFile("user.txt")
'make an array from the data file
UsersList = Split(oTextStream.ReadAll, vbNewLine)
'close the data file
oTextStream.Close

For Each UserString In UsersList
		'First grab the DistinguishedName
		UserDN = SearchDistinguishedName(UserString)
		'Now bind to the user object
		Set UserObj = GetObject("LDAP://" & UserDN)
		'Find the Relative Distinguished Name (RDN)
		UserRDN = UserObj.Name
		'Subtract the length of the RDN plus 4 more for the comma OU=
		'You now have the full path to the users OU
		FullOU = Right(UserDN,Len(UserDN)-Len(UserRDN)-4)
		'Now split the OU on the comma to get the users OU.
		OUArray = Split(FullOU,",")
		UserOU= OUArray(0)
		
		'Finally now we can append an SMTP address.
		    Set objRecip = UserObj
		    sAddress = "SMTP:" & UserString & "@" & UserOU& ".companyname.com"
		    bIsFound = False
       vProxyAddresses = objRecip.ProxyAddresses
       nProxyAddresses = UBound(vProxyAddresses)
       i = 0
       Do While i <= nProxyAddresses
          email = vProxyAddresses(i)
          If Left (email,5) = "SMTP:" Then 
                vProxyAddresses (i) = "smtp:" & Mid (email,6)
          End If       
          If vProxyAddresses(i) = sAddress  Then
             bIsFound = True
                Exit Do
          End If
          i = i + 1
    Loop
       If Not bIsFound Then
           ReDim Preserve vProxyAddresses(nProxyAddresses + 1)
           vProxyAddresses(nProxyAddresses + 1) = sAddress
           objRecip.ProxyAddresses = vProxyAddresses
              oUser.SetInfo
       End If

Next		


Public Function SearchDistinguishedName(ByVal vSAN)
    ' Function:     SearchDistinguishedName
    ' Description:  Searches the DistinguishedName for a given SamAccountName
    ' Parameters:   ByVal vSAN - The SamAccountName to search
    ' Returns:      The DistinguishedName Name
    Dim oRootDSE, oConnection, oCommand, oRecordSet

    Set oRootDSE = GetObject("LDAP://rootDSE")
    Set oConnection = CreateObject("ADODB.Connection")
    oConnection.Open "Provider=ADsDSOObject;"
    Set oCommand = CreateObject("ADODB.Command")
    oCommand.ActiveConnection = oConnection
    oCommand.CommandText = "<LDAP://" & oRootDSE.get("defaultNamingContext") & _
        ">;(&(objectCategory=User)(samAccountName=" & vSAN & "));distinguishedName;subtree"
    Set oRecordSet = oCommand.Execute
    On Error Resume Next
    SearchDistinguishedName = oRecordSet.Fields("DistinguishedName")
    On Error GoTo 0
    oConnection.Close
    Set oRecordSet = Nothing
    Set oCommand = Nothing
    Set oConnection = Nothing
    Set oRootDSE = Nothing
End Function

I hope you find this post helpful.

Regards,

Mark

 

[jpm121]

Mark, I don't know if that works or not, but it's impressive. * for you.

 

[markdmac]

Thanks, it is all code I Frankensteined together from other scripts I have written, but I am confident you will not have a problem (barring any strange copy paste errors on line wrapping).

I hope you find this post helpful.

Regards,

Mark