Note: This is part 2; part 1 can be found here.

After the post on experiences regarding Cross-Forest Mailbox Move, the problems with the “sample” Powershell script and the script created in good ol’ VB, I got lots of requests to publish the script. After thinking this over, I made it ready for publishing. That means stripping excessive code and changing domain names etc. to a more descriptive labels.

The script does require some explanation:

• The script uses 1 input file (users.txt) and produces 1 output file (output.log) (included below);
• The reason for sending output to screen (optional) as well as file is to be able to check it properly (e.g. using notepad) when running it for a set of users;
• users.txt contains a single line with the source and target account names. This is the same file we used for ADMT imput. Reason for having a source as well as a new account name is that in the migration process account are renamed. ADMT can do this for you, but the script will need both the old and the new name name to connect to the objects and copy/set several attributes;
• It’s VB, had been kept simple and didn’t went through a code beautifier. That means no full function headers, input/output descriptions or extensive error handling;
• Modify the constants using information from your environment, e.g. source/target domain, servers, LegacyExchangeDN etc.
• The script uses fixed servers. This is to make sure we’re talking to the same server(s) as ADMT and to prevent replication issues because of lag;
• Use the script at your own risk. I cannot accept any responsibility for consequences when using this in your production environment;
• Use it in a lab environment first; test, test, test!

Users.txt

SourceName,TargetSAM
jtest,jtest

CrossForestMovePrep.vbs

'*--------------------------------------------------------------------------------
'* Name     : PrepareForestMove
'* Created By      : Michel de Rooij
'* E-mail    : michel@eightwone.com
'* Date            : 20100217
'* Version    : 0.22
'*--------------------------------------------------------------------------------
'* Changes:
'* 0.21 Initial version
'* 0.22 Made changes to address single-value proxyAddress attributes
'*--------------------------------------------------------------------------------

Option Explicit

Const strUserfile            = "users.txt"
Const strOutputFileName            = "output.log"
Const DEBUGOUTPUT            = 1

Const conSourceServer               = "dc.olddomain.nl"
Const conSourceDomain                = "olddomain.nl"
Const contargetServer                = "dc.newdomain.com"
Const conTargetDomain                = "newdomain.com"

Const conLegacyExchangeDN            = "/o=NEWEXORG/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn="
Const conTargetEmailDomain            = "target.com"

' AD putex cmds
Const ADS_PROPERTY_CLEAR = 1
Const ADS_PROPERTY_UPDATE = 2
Const ADS_PROPERTY_APPEND = 3
Const ADS_PROPERTY_DELETE = 4

' FileSystem
Const ForWriting =2
Const ForReading =1

'*********************************************************
' MAIN
'*********************************************************

Dim oFSO, strFile, objFile, hOutputFileHandle, bProcessLine, strLine
Dim arrUsers, strUser, strCmd, strNewUser

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set hOutputFileHandle= oFSO.OpenTextFile( strOutputFileName, ForWriting, True)

debug("Start")

strFile= strUserFile

if NOT oFSO.fileExists( strFile) then
 die( "Input file "& strFile& " does not exist")
end if

debug("Reading names from "& strFile)
set objFile= oFSO.OpenTextFile( strFile, ForReading, True)

while not objFile.atEndOfStream

 bProcessLine= True
 strLine= objFile.readLine

 if isEmpty(strLine) then
 bProcessLine= False
 Else
 If left(strLine, 1)= ";" Then
 bProcessLine= False
 Else
 If inStr( strLine, ",") > 0 Then
 ' Line OK
 arrUsers= split( strLine, ",")
 strUser= arrUsers(0)
 strNewUser= arrUsers(1)

 If strUser= "SourceName" Then
 ' Input file header, skip        
 bProcessLine= False
 End If
 Else
 bProcessLine= False
 debug("** INFO: Skipping line "& strLine)
 End If    
 End If
 End If

 If bProcessLine Then

 debug(strNewUser& ": Syncing Exchange Attributes from "& struser)
 syncAttributes strUser, conSourceServer, conSourceDomain, strNewUser, conTargetServer, conTargetDomain

 End If
Wend

debug("Finished")

objFile.Close
hOutputFileHandle.Close  

set hOutputFileHandle= Nothing
set objFile= Nothing
set oFSO= Nothing

wscript.quit(0)

'*******************************************************************
' Purpose: output to screen when DEBUGOUTPUT is 1, always to file
'*******************************************************************
Function debug(strMsg)
 hOutputFileHandle.write ("["& FormatDateTime(now(),4) & "] "& strMsg & chr(13)& chr(10))
 if DEBUGOUTPUT=1 then
 wscript.echo strMsg
 end if
End Function

'*********************************************************
' Purpose: terminate with message
'*********************************************************
Function die(strMsg)
 wscript.echo strMsg
 wscript.quit (1)
End Function

'*********************************************************
' displayString
' Returns string from varType item/elements
'*********************************************************
Function displayString( varObj)
 Dim tmp, item
 tmp= ""
 select case VarType( varObj)

 Case vbEmpty
 tmp= "(Empty)"
 Case vbNull
 tmp= "(Null)"
 Case vbInteger, vbLong, vbSingle, vbDouble, vbByte, vbDecimal, vbCurrency, vbDate, vbBoolean
 tmp= cStr( varObj)
 Case vbString
 tmp= varObj
 Case vbObject
 tmp= "(Object)"
 Case vbvariant
 tmp= "(Variant)"
 Case 8209
 tmp= "("& OctetToHexStr( varObj)& ")"
 Case vbArray, 8204
 For each item in varObj
 If tmp="" Then
 tmp= tmp+ item
 Else
 tmp= tmp+ ", "+item
 End If
 Next
 tmp= "["& tmp& "]"
 Case Else

 End Select

 displaystring= tmp& " #"& varType( varObj)

End Function

'*********************************************************
' OctetToHexStr
' Convert OctetString (byte array) to Hex string.
'*********************************************************
Function OctetToHexStr (arrbytOctet)
 Dim k
 OctetToHexStr = ""
 For k = 1 To Lenb (arrbytOctet)
 OctetToHexStr = OctetToHexStr & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
 Next
End Function

'*********************************************************
' syncAttributes
' migrates attributes from source to target
'*********************************************************
Function syncAttributes (strUser, SourceServer, SourceDomain, strNewUser, TargetServer, TargetDomain)

 dim strDNSource, strDNTarget, objSource, objTarget, n, strMail
 strDNSource= getDN( struser, SourceServer, SourceDomain, "")
 strDNTarget= getDN( strNewuser, TargetServer, TargetDomain, "")
 If strDNSource<>"" AND strDNTarget <> "" Then
 set objSource= getObject( "LDAP://"& SourceServer& "/"& strDNSource)
 set objTarget= getObject( "LDAP://"& TargetServer& "/"& strDNTarget)

 copyAttribute "mail", objSource, objTarget, False
 copyAttribute "mailNickname", objSource, objTarget, False
 copyAttribute "msExchMailboxGuid", objSource, objTarget, False
 setAttribute "targetaddress", objSource.get( "mail"), objTarget
 copyAttribute "proxyAddresses", objSource, objTarget, True
 addAttribute "proxyAddresses", "X500:"& objSource.get( "LegacyExchangeDN"), objTarget

 strMail= objSource.get( "mail")
 n= instr( strMail, "@")
 debug( strMail)
 addAttribute "proxyAddresses", "smtp:"& left( strMail, n-1)& "@"& conTargetEMailDomain, objTarget

 setAttribute "msExchRecipientDisplayType", -2147483642, objTarget
 setAttribute "msExchRecipientTypeDetails", 128, objTarget
 setAttribute "legacyExchangeDN", conLegacyExchangeDN& objSource.get("cn"), objTarget

 objTarget.setInfo

 Else
 debug("*** ERR: Cannot retrieve DNs for Source or Target")
 syncAttributes= False
 End If
End Function

'*********************************************************
' getDN
' Retrieves the DN for a user object
'*********************************************************
Function getDN( struser, strServer, strDomain, strOU)
 dim objConn, objCmd, strQuery, objRS, strAttr, strRDNLDAP, strDNSLDAP
 strRDNLDAP= RDN2LDAPPATH( strOU)
 strDNSLDAP= DNSDomain2LDAPPath( strDomain)
 strAttr= "distinguishedName"
 set objConn= createObject( "ADODB.Connection")
 set objCmd= createObject( "ADODB.Command")
 objConn.Provider= "ADsDSOObject"
 objConn.Open "ADs provider"
 objCmd.ActiveConnection= objConn
 strQuery= "<LDAP://"& strServer
 If strServer <> "" Then
 strQuery= strQuery& "/"
 End If
 strQuery= strQuery& strRDNLDAP
 If strOU <> "" Then
 strQuery= strQuery& ","
 End If
 strQuery= strQuery& strDNSLDAP& ">"
 strQuery= strQuery+ ";(&(objectCategory=person)(objectClass=user)(SAMAccountName="& strUser&"));"& strAttr& ";subtree"
 objCmd.CommandText = strQuery
 on error resume next
 set objRS= objCmd.execute
 if err.number <> 0 Then
 debug( "*** ERR: Error "& err.number& " executing ["& strQuery& "]")
 getDN= ""
 Else
 on error goto 0
 Select Case objRS.recordCount
 Case 0
 debug( "*** ERR: User object "& struser& " not found")
 getDN= ""
 Case 1
 getDN= objRS.Fields( strAttr)
 'debug( getDN)
 Case Else
 debug("*** ERR: Ambigious user object "& struser)
 getDN= ""
 End Select
 End If
 set objRS= Nothing
 set objCmd= Nothing
 set objConn= Nothing
End Function

'*********************************************************
' DNSDomain2LDAPPath( str)
' Makes an LDAP notation for a DNS domain name
' e.g. corp.local => DC=corp,DC=local
'*********************************************************
Function DNSDomain2LDAPPath( str)
 Dim tmp1, tmp2, tmp3
 tmp1= split( str, ".")
 tmp2= ""
 For each tmp3 in tmp1
 If tmp2<>""  then
 tmp2= tmp2& ","
 End If
 tmp2= tmp2& "dc="& tmp3
 Next
 DNSDomain2LDAPPath= tmp2
End Function

'*********************************************************
' RDN2LDAPPath( str)
' Makes an LDAP notation for a Relative Distinguished Name
' e.g. Domain Accounts/3rd party => OU=3rd party,OU=Domain Accounts
'*********************************************************
Function RDN2LDAPPath( str)
 Dim tmp1, tmp2, tmp3
 tmp1= split( str, "/")
 tmp2= ""
 For each tmp3 in tmp1
 If tmp2<>"" then
 tmp2= ","& tmp2
 End If
 tmp2= "ou="& tmp3& tmp2
 Next
 RDN2LDAPPath= tmp2
End Function

'*********************************************************
' copyAttribute
' Copies attribute(s) to target
'*********************************************************
Function copyAttribute( strAttribute, objSource, objTarget, boolMulti)
dim boolUpdate, varItem
If isEmpty( objSource.get( strAttribute)) Then
  debug( strAttribute& " not set, clearing")
  objTarget.PutEx ADS_PROPERTY_CLEAR, strAttribute, 0
Else
  varItem= objSource.get( strAttribute)
  If boolMulti Then
    if isArray( varItem) Then
      debug( "Setting "& strAttribute& " to multi-value "& displayString( varItem))
      objTarget.PutEx ADS_PROPERTY_UPDATE, strAttribute, varItem
    Else
      debug( "Setting "& strAttribute& " to single-value "& displayString( varItem))
      objTarget.PutEx ADS_PROPERTY_UPDATE, strAttribute, array( varItem)
    End If
  Else
    debug( "Setting "& strAttribute& " to "& displayString( varItem))
    objTarget.Put strAttribute, varItem
  End If
End If
on error goto 0
objTarget.SetInfo
End Function

'*********************************************************
' setAttribute
' Sets attribute to target
'*********************************************************
Function setAttribute( strAttribute, strValue, objTarget)
 debug("Setting "& strAttribute& " to "& displayString(strValue))
 objTarget.Put strAttribute, strValue
 objTarget.SetInfo
End Function

'*********************************************************
' addAttribute
' Adds attribute to target
'*********************************************************
Function addAttribute( strAttribute, varAttribute, objTarget)
 dim boolUpdate, tmp
 boolUpdate= True
 If isEmpty( varAttribute) Then
 ' not set, skipping
 Else
 'on error resume next
 If isEmpty( objTarget.get( strAttribute)) Then
 boolUpdate= True
 Else
 If isArray( objTarget.get( strAttribute)) Then
 For each tmp in objTarget.get( strAttribute)
 If tmp = varAttribute Then
 boolUpdate= False
 End If
 Next
 Else
 boolUpdate= varAttribute= objTarget.get( strAttribute)
 End If
 End If
 on error goto 0
 If boolUpdate Then
 debug("Adding "& varAttribute& " to "& strAttribute)
 objTarget.PutEx ADS_PROPERTY_APPEND, strAttribute, array( varAttribute)
 Else
 debug( varAttribute& " already in "& strAttribute)
 End If
 End If
 objTarget.SetInfo
End Function

Output.log (sample)

[16:24] Start
[16:24] Reading names from users.txt
[16:24] jtest: Syncing Exchange Attributes from jtest
[16:24] Setting mail to jtest@source.nl #8
[16:24] Setting mailNickname to jtest #8
[16:24] Setting msExchMailboxGuid to (70C2360FB0330346A925172CA0473B9F) #8209
[16:24] Setting targetaddress to jtest@target.com #8
[16:24] Setting proxyAddresses to [SMTP:jtest@source.nl, X400:c=US;a= ;p=DemoOrg;o=Exchange;s=Old;g=Mr;] #8204
[16:24] Adding X500:/o=DemoOrg/ou=First Administrative Group/cn=Recipients/cn=jtest to proxyAddresses
[16:24] jtest@source.nl.nl
[16:24] Adding smtp:jtest@target.com to proxyAddresses
[16:24] Setting msExchRecipientDisplayType to -2147483642 #3
[16:24] Setting msExchRecipientTypeDetails to 128 #2
[16:24] Setting legacyExchangeDN to /o=NEWORG/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=Mr Old #8
[16:24] Finished