Oct 29


' 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
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

'Search AD
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
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)
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))
arrEmail(i) = strEmail
End If
i = i + 1

'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
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)

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

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

'Kill User Objects
Set objUser = Nothing
End If



'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
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
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
logName = scriptPath & fileName
End If
Dim logFile
If blnNewLog = True Then
Set logFile = objFSO.CreateTextFile(logName, True)
If objFSO.FileExists(logName) Then
Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
Set logFile = objFSO.CreateTextFile(logName, True)
End If
End If
logFile.WriteLine logMessage
Set objFSO = Nothing

On Error Goto 0

End Sub


Apr 01


' EmailParts.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 4/1/2012
' COMMENTS: Four methods to break an email address into the local and
' domain parts. I prefer the string methods because you can make them
' 1-liners, doesn't require additional variables, and simplifies error
' handling.  
Option Explicit

Call EmailParts1("john.doe@domain.com")
Call EmailParts2("john.doe@domain.com")
Call EmailParts3("john.doe@domain.com")
Call EmailParts4("john.doe@domain.com")

'METHOD1(String) - Left/Right with Instr
Sub EmailParts1(email)
    Wscript.Echo "METHOD 1:" &amp; vbCrLf &amp; _
    "Email: " &amp; email &amp; vbCrLf &amp; _
    "Local: " &amp; Left(email,InStr(1,email,"@",1)-1) &amp; vbCrLf &amp; _
    "Domain: " &amp; Right(email,(Len(email)-InStr(1,email,"@",1))+1)  
End Sub

'METHOD2(String) - Left/Right with InstrRev
Sub EmailParts2(email)
    Wscript.Echo "METHOD 2:" &amp; vbCrLf &amp; _
    "Email: " &amp; email &amp; vbCrLf &amp; _
    "Local: " &amp; Left(email,InstrRev(email,"@")-1) &amp; vbCrLf &amp; _
    "Domain: " &amp; Right(email,(Len(email)-Instr(email,"@"))+1)
End Sub

'METHOD3(String) - Mid with InStr
Sub EmailParts3(email)
    Wscript.Echo "METHOD 3:" &amp; vbCrLf &amp; _
    "Email: " &amp; email &amp; vbCrLf &amp; _
    "Local: " &amp; Mid(email, 1, InStr(email, "@")-1) &amp; vbCrLf &amp; _
    "Domain: " &amp; Mid(email,InStr(email,"@"),Len(email)-(InStr(email,"@")-1))
End Sub

'METHOD4(Array) - Split dumps into an array (NOT RECOMMENDED)
Sub EmailParts4(email)
    Dim arrEmail: arrEmail = Split(email,"@")
    arrEmail(1) = "@" &amp; arrEmail(1) 'Need to add @ back in
    Wscript.Echo "METHOD 4:" &amp; vbCrLf &amp; _
    "Email: " &amp; email &amp; vbCrLf &amp; _
    "Local: " &amp; arrEmail(0) &amp; vbCrLf &amp; _
    "Domain: " &amp; arrEmail(1)
End Sub