ChangePrimaryEmailDomain.vbs

'=========================================================================
' ChangePrimaryEmailDomain.vbs
' VERSION: 1.1 - Corrected Case Sensitive Error When Matching SMTP
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 10/29/2012
' COMMENTS: Pass the ADsPath or Dinstinguished Name of the User/OU and New
' Email Domain to Modify the User(s) Primary SMTP Email Domain. The Script Will
' Grab the Local Part of the Users Current Primary Email, Append the New
' Domain to the End to Create the New Primary Email, and Make the Current Primay
' Email an Alias. It Will Also Update the Mail Attribute So the New Primary
' Email Displays On the General Tab of the Users Property in AD Users and Computers.
' Any Non-Email Enabled Users Will Be Skipped.
' EXAMPLE: Modify the User John Doe's Primary Email Domain (jdoe@domain.com -> jdoe@newdomain.com)
' Dim UserOrOU: UserOrOU = "CN=John Doe,CN=Users,DC=domain,DC=com"
' Dim NewDomain: NewDomain = "@newdomain"
' EXAMPLE: Modify All Users Primary Email Domain in an OU
' Dim UserOrOU: UserOrOU = "OU=Financial,DC=domain,DC=com"
' Dim NewDomain: NewDomain = "@newdomain.com"
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim UserOrOU: UserOrOU = "OU=Financial,DC=domain,DC=com"
Dim NewDomain: NewDomain = "@newdomain.com"
' ------ END CONFIGURATION ------

Dim strLog: strLog = Replace(Wscript.ScriptName,".vbs",".txt")
Call ChangePrimaryEmailDomain(UserOrOU,NewDomain)
Wscript.Echo "Finished"

Private Function ChangePrimaryEmailDomain(strDN, strNewDomain)

On Error Resume Next

'Ensure We have a DN
strDN = Replace(strDN,"LDAP://","",1,1,1)

'Start Log File
Call Logger(strLog, "++++++++++++++++++++++++++++++++++++++++", True)
Call Logger(strLog, "+ " & Wscript.ScriptName, False)
Call Logger(strLog, "+ DN: " & strDN, False)
Call Logger(strLog, "+ New Domain: " & strNewDomain, False)
Call Logger(strLog, "++++++++++++++++++++++++++++++++++++++++" & vbCrLf & vbCrLf & vbCrLf, False)

'PutEx Constants
Const ADS_PROPERTY_CLEAR = 1
Const ADS_PROPERTY_UPDATE = 2
Const ADS_PROPERTY_APPEND = 3
Const ADS_PROPERTY_DELETE = 4

'Search AD
Const ADS_SCOPE_SUBTREE = 2
Dim objConnection: Set objConnection = CreateObject("ADODB.Connection")
Dim objCommand: Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = "SELECT AdsPath FROM 'LDAP://" & strDN & "' WHERE objectClass='user' AND objectCategory='person'"
Dim objRecordSet: Set objRecordSet = objCommand.Execute
Dim objUser, strEmail, strOldPrimary, strNewPrimary
Dim arrEmail()
Dim arrProxyAddresses
Dim i
Dim blnFound

' Process Results and List Emails
If objRecordSet.RecordCount < 1 Then
Call Logger(strLog, "Error No Records Found for DN", False)
Exit Function
End If
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
Set objUser = GetObject(objRecordSet.Fields("AdsPath").Value)
Call Logger(strLog, vbCrLf & vbCrLf & "USER:" & objUser.AdsPath & vbCrLf & "=====================================================", False)
i = 0
'Build Array of Email Addresses and Get Primary SMTP
Call Logger(strLog, "Original Email Addresses" & vbCrLf & "------------------------------", False)
If Not IsArray(objUser.proxyAddresses) Then
'SKIP - Not Email Enabled
Call Logger(strLog, "SKIPPING - NOT EMAIL ENABLED", False)
Else
For Each strEmail in objUser.proxyAddresses
Call Logger(strLog, strEmail, False)
'Build Array of Email Addresses and Make All SMTP Addresses Lowercase
ReDim Preserve arrEmail(i)
If Left(strEmail,5) = "SMTP:" Then
strOldPrimary = "SMTP:" & LCase(Mid(strEmail,6))
arrEmail(i) = strOldPrimary
Elseif Left(strEmail,5) = "smtp:" Then
arrEmail(i) = "smtp:" & LCase(Mid(strEmail,6))
Else
arrEmail(i) = strEmail
End If
i = i + 1
Next

'Build New Primary SMTP (Assuming Local and Domain Are Lowercase From Above)
strNewPrimary = Left(strOldPrimary,InStr(1,strOldPrimary,"@",1)-1) & strNewDomain

'Modify Array(Assuming Local and Domain Are Lowercase From Above)
blnFound = False
For i = LBound(arrEmail) to UBound(arrEmail)
'Make the Old SMTP an Alias
If arrEmail(i) = strOldPrimary Then
arrEmail(i) = Replace(strOldPrimary,"SMTP:","smtp:",1,1,0)
End If

'New Primary SMTP is an Alias, Make it Primary
If arrEmail(i) = Replace(strNewPrimary,"SMTP:","smtp:",1,1,0) Then
blnFound = True
arrEmail(i) = strNewPrimary
End If
Next
If blnFound = False Then
'Add New Primary Email If It Didn't Exist
i = UBound(arrEmail) + 1
ReDim Preserve arrEmail(i)
arrEmail(i) = strNewPrimary
End If

'Log Modified Results
Call Logger(strLog, vbCrLf & "Modified Email Addresses" & vbCrLf & "------------------------------", False)
For i = LBound(arrEmail) to UBound(arrEmail)
Call Logger(strLog, arrEmail(i), False)
Next

'Write Results
objUser.PutEx ADS_PROPERTY_UPDATE, "proxyAddresses", arrEmail
objUser.SetInfo
Call Logger(strLog, "mail=" & Replace(strNewPrimary,"SMTP:","",1,1,1), False)
objUser.Put "mail", Replace(strNewPrimary,"SMTP:","",1,1,1)
objUser.SetInfo

If Err.Number <> 0 Then
Err.Clear
Call Logger(strLog, "RESULT: !~ERROR~!", False)
Else
Call Logger(strLog, "RESULT: SUCCESS", False)
End If

'Kill User Objects
Set objUser = Nothing
End If

objRecordSet.MoveNext

Loop

'Kill Search Objects
Set objConnection = Nothing
Set objCommand = Nothing

On Error Goto 0

End Function

Private Sub Logger(fileName, logMessage, blnNewLog)

On Error Resume Next

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
Dim logName
If InStr(1,fileName,"\",1) > 0 Then
logName = fileName
If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
If Not objFSO.FolderExists(logName) Then
If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
objFSO.CreateFolder logName 'Create Folder In Current Path
Exit Sub
Else
Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
Exit Sub
End If
End If
Else
If Not objFSO.FileExists(logName) Then
If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
End If
End If
End If
End If
Else
logName = scriptPath & fileName
End If
Dim logFile
If blnNewLog = True Then
Set logFile = objFSO.CreateTextFile(logName, True)
Else
If objFSO.FileExists(logName) Then
Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
Else
Set logFile = objFSO.CreateTextFile(logName, True)
End If
End If
logFile.WriteLine logMessage
logFile.Close
Set objFSO = Nothing

On Error Goto 0

End Sub

 

Leave a Reply

Your email address will not be published. Required fields are marked *