My company changed its name a couple weeks ago and so I needed to add a new primary address for those who had the old domain as a primary, and move the old primary to a secondary. I was surprised that I couldn’t hardly find any existing scripts to accommodate such an endeavor so I had to resort to doing it myself.

This script goes through all accounts in a given AD domain and whose primary email address is the "old" SMTP domain name, makes the primary a secondary, takes the username portion of the address and appends the new domain and makes it the new primary. I log all of the old address and new addresses to the screen, so redirect the output to a file to capture that. It doesn’t check for preexisting addresses so conflicts can occur. I had previously done my own extract to look for those, so dealing with them manually was easier and faster than coding for that.

I modified the script each time I ran it to change the AD domain I wanted to search (though I could have just defined an array of domain names and looped through each of them), and ran it against DLs and public folders, too, adjusting the filter to return the different object types. You will need to do the same.

Download the code here, or copy below.

Option Explicit
'Set value for domain to run against and LDAP filter to use
'Also set the old and new SMTP domain names on line 33
'If you need to update the display name to remove a company designation, that is line 80
dim strDomain, strSearchFilter
strdomain = "nbdomain" 'Put the NetBIOS domain name here
'Update filter below to return the object types you want, e.g., users, groups, publicfolders
strSearchFilter = "(&(objectcategory=publicfolder)(mailnickname=*)(mail=*@olddomain.com))" 

'Connect to AD
Dim objConnection, objCommand, objRecordSet, objUser
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 10000

'Retrieve user objects
Const ADS_PROPERTY_UPDATE = 2
objCommand.CommandText = "<LDAP://" & strDomain & ">; " & strSearchFilter & "; distinguishedname"
Set objRecordSet = objCommand.Execute
wscript.echo "Count:" & objRecordSet.RecordCount
While not objRecordSet.EOF
	Set objUser = GetObject("LDAP://" & Replace(objRecordSet.Fields("distinguishedname"),"/", "\/"))
	wscript.echo objUser.displayName & "; " & strDomain & "\" & objUser.sAMAccountName

	'Set values for new email addresses
	Dim blnExists, strNewMail, i, strOldProxy, strAddress
	Dim arrProxyAddresses, intProxyAddresses, strNewProxy, intProxyForLoop
	arrProxyAddresses = objUser.proxyAddresses
	intProxyAddresses = UBound(arrProxyAddresses)
	intProxyForLoop = intProxyAddresses	

	'Set value for mail
	strNewMail = Replace(objUser.mail, "@olddomain.com", "@newdomain.com")
	wscript.echo vbTab & "Old mail: " & objUser.mail
	wscript.echo vbTab & "New mail: " & strNewMail
	wscript.echo ""

	'Log old SMTP proxies
	For each strOldProxy in arrProxyAddresses
		If UCase(Left(strOldProxy,5)) = "SMTP:" Then
			wscript.echo vbTab & "Old proxies: " & strOldProxy
		End If
	Next

	'Change primary to secondary and add new primary
	blnExists = False
	For i = 0 to intProxyForLoop
		dim strAddressType, strAddressBody
		strAddressType = Left(arrProxyAddresses(i),5)
		strAddressBody = Mid(arrProxyAddresses(i),6)
		If UCase(strAddressType) = "SMTP:" Then
			If strAddressType = "SMTP:" Then
	    			arrProxyAddresses(i) = Replace(arrProxyAddresses(i), "SMTP:", "smtp:")
	    		Else
	    			If LCase(strAddressBody) = LCase(strNewMail) Then
					blnExists = True
					arrProxyAddresses(i) = Replace(arrProxyAddresses(i), "smtp:", "SMTP:")
				End If
			End If
		End If
		If i = intProxyForLoop Then
			If Not blnExists Then
				ReDim Preserve arrProxyAddresses(intProxyAddresses + 1)
				arrProxyAddresses(intProxyAddresses + 1) = "SMTP:" & strNewMail
			End If
		End If
	Next

	'Log new SMTP proxies
	For each strNewProxy in arrProxyAddresses
		If UCase(Left(strNewProxy,5)) = "SMTP:" Then
			wscript.echo vbTab & "New proxies: " & strNewProxy
		End If
	Next
	wscript.echo ""

	'Remove component designation from display name
	Dim strDisplayName
	strDisplayName = Replace(objUser.displayName, " - COMPANY", "")
	wscript.echo vbTab & "New display: " & strDisplayName

	'Commit changes
	objUser.Put "mail", strNewMail
	objUser.PutEx ADS_PROPERTY_UPDATE, "proxyAddresses", arrProxyAddresses
	objUser.Put "displayName", strDisplayName
	On Error Resume Next
	objUser.SetInfo
	If Err.Number <> 0 Then
		wscript.echo "Update unsuccessful!"
	Else
		wscript.echo "Update successful"
	End If
	wscript.echo vbCRLF
	On Error Goto 0
	objRecordSet.MoveNext
Wend

Set objRecordSet = Nothing
Set objUser = Nothing
Set objCommand = Nothing
Set objConnection = Nothing