'========================================================================= ' ChangePrimaryEmailDomain.vbs ' VERSION: 1.1 - Corrected Case Sensitive Error When Matching SMTP ' AUTHOR: Brian Steinmeyer ' EMAIL: [email protected] ' WEB: https://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 ([email protected] -> [email protected]) ' 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
