Adding a Hosted Exchange User With VBScript
Originally published September 30, 2004
(Note November 13, 2007: this will work with Exchange 2000 and Exchange 2003, but not with Exchange 2007.)
Getting back to scripting, I've finally scrubbed and sanitized and cleaned up one of my core provisioning scripts.
While finding small example scripts that do small things for Exchange are pretty easy to find, full grown-up scripts, with error checking, parameter validation, that properly deal with the complex interactions between the various pieces of Exchange and Windows and Active Directory involved -- there are few of these available for general perusal and examination.
This is my contribution.
I've also included a number of references to KB articles, where I felt like something wasn't very obvious. This script shows a combination of scripting techniques and technologies: ADSI, ADO, CDO, CDOEXM, WMI, WQL, etc. There is lots of stuff that you can pick up and use in your own scripts.
While I could write pages on the why and how of this script, I like to think that it's very clear why I did what I did.
Is this bug-free? Almost certainly not -- but it works for me. No warranties, blah blah blah. The big deal is that it takes a five-minute GUI'based, error-prone manual provisioning task and turns it into a five-second task that can be shot out of Excel or another script. If you use it, I'd appreciate a name-mention - but no biggie either way.
In my files, this is nicely formatted, with tabs and stuff. It didn't paste into .Text very well at all, but I'm certainly not going to reformat each and every line....basically just replace each space at the start of a line with a tab. :-)
There is some “business“ logic in here, but very little. It is designed to deal with a hosted environment for Exchange, but modifying it for a non-hosted environment would be pretty doggone simple (change OU_HOSTING, pre-define the OAL, and eliminate domain_prefix are probably it).
The script also sets some things that you probably wouldn't do in a non-hosted environment: set don't expire password, set msExchQueryBaseDN, and set msExchUseOAB. But you might - and except for the “don't expire password“, they certainly don't hurt.
There is a matching “exch-add-client.vbs“ which does the basic setup for a new client. It's not “clean“ yet, and one thing has still not been automated. As soon as I figure out how to do that, I'll post it too.
Enjoy and good luck,
Michael
'
' exch-add-user.vbs
'
' Add an Exchange hosted user account.
'
' Required parameters:
'
' Name Example value
' 1) domain zippy.com
' 2) domain_prefix zip
' 3) AccountName info
' 4) firstname (givenName) John
' 5) lastname (sn) Doe
' 6) password z1ppy
' 7) OAB "Offline Address List - Zippy"
'
' This script does everything required to add a new user to a hosted
' Exchange domain.
'
' This script is a "production quality" script. It does error checking,
' parameter validity checking, and backs out any changes (i.e., removes
' a temporary user object if it's already been created) in case an
' error occurs. However, error messages are system-level messages and
' aren't translated for the non-technical user (well, two are, but only
' two -- object not found and object already exists).
'
' This script has only been tested on Windows XP workstations which are
' talking to Exchange Server 2003. Minor changes would be required to
' support the Exchange 2000 Server Management Tools and to support Windows
' 2000 Professional workstations.
'
' To modify for your environment, change the OU_HOSTING, ExchServer, and
' Trustee constants as required. If you are using non-default names for
' your mailbox stores, that will require changing as well. If you do not
' want an additional Trustee added to the mailbox, set Trustee to "" (the
' empty string).
'
Option Explicit
Const OU_HOSTING = "OU=Hosting" ' the OU where I put customer OU's
Const ExchServer = "EXCHANGE" ' the exchange server whose default mailbox store I'll use
Const Trustee = "Domain Admins" ' an extra ACL to add to the mailbox
Const bDebug = False ' verbose output
Dim strNamingContext, strConfigContext
Dim strOrgDN
Dim strNetBIOSDomain, strNetBIOSComputer
Dim strTrustee
Dim strMailboxStoreDN, strOABContainer
Dim strServerList, strServerListDN
Dim strOALList, strUserOAL
Dim Com, Conn, Rs ' for ADO
' Constants we need for ADSI calls
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Const ADS_PROPERTY_APPEND = 3
Const ADS_PROPERTY_DELETE = 4
Const ADS_ACETYPE_ACCESS_ALLOWED = 0
Const ADS_ACEFLAG_INHERIT_ACE = &H2
' Constants we need for WBEM calls
Const wbemFlagReturnImmediately = &H10
Const wbemFlagForwardOnly = &H20
' Main program
If WScript.Arguments.Count <> 7 Then
e "Usage: exch-new-user.vbs domain domain_prefix accountname firstname lastname password OAB"
WScript.Quit 1
End If
strUserOAL = WScript.Arguments (6)
Call DoSetup
CreateHostedUser WScript.Arguments (0), WScript.Arguments (1), _
WScript.Arguments (2), WScript.Arguments (3), _
WScript.Arguments (4), WScript.Arguments (5), _
WScript.Arguments (6)
e "Done."
Call ClearSystemInfo
WScript.Quit 0
Sub DoSetup
Call GetSystemInfo
Call GetAllServers
Call GetAllOfflineAddressLists
If Not FindServer (ExchServer) Then
e "*** Error: " & ExchServer & " is not an Exchange server in this A/D forest."
e "*** Error: This program will fail. Terminating."
Call ClearSystemInfo
WScript.Quit 1
End If
If Not FindServer (strNetBIOSComputer) Then
If Not IsExchangeManagementInstalled Then
e "*** ERROR: Exchange Management is not installed on this computer."
e "*** ERROR: This program will fail. Terminating."
Call ClearSystemInfo
WScript.Quit 1
End If
e "*** WARNING: This computer is not an Exchange server."
e "*** WARNING: This program has not been tested in this configuration. Continuing."
End If
If Not FindOAL (strUserOAL) Then
e "*** ERROR: Specified OAL '" & strUserOAL & "' does not exist."
e "*** ERROR: This program will fail. Terminating."
Call ClearSystemInfo
WScript.Quit 1
End If
' build the fully qualified trustee based on this domain
If Len (Trustee) > 0 Then
strTrustee = strNetBIOSDomain & "\" & Trustee
Else
strTrustee = ""
End If
' getting the strMailboxStoreDN from A/D is pretty easy,
' but with multiple servers, you need to pick one. this
' is the one I pick.
strMailboxStoreDN = "CN=Mailbox Store (" & ExchServer & ")," & _
"CN=First Storage Group," & _
"CN=InformationStore," & _
"CN=" & ExchServer & "," & _
"CN=Servers," & _
"CN=First Administrative Group," & _
"CN=Administrative Groups," & _
strOrgDN ' this is the DN of the Offline Address Books container. the
' value of msExchUseOAB is a specific OAB in this container.
strOABContainer = "CN=Offline Address Lists," & _
"CN=Address Lists Container," & _
strOrgDN
End Sub
Sub GetSystemInfo
Dim objSystemInfo, objWSHNetwork, objRootDSE
Set objRootDSE = GetObject ("LDAP://RootDSE")
strNamingContext = objRootDSE.Get ("defaultNamingContext")
strConfigContext = objRootDSE.Get ("configurationNamingContext")
Set objRootDSE = Nothing ' get the NetBIOS domain name
Set objSystemInfo = CreateObject ("ADSystemInfo")
strNetBIOSDomain = objSystemInfo.DomainShortName
Set objSystemInfo = Nothing
' get the NetBIOS computer name
Set objWSHNetwork = CreateObject ("WScript.Network")
strNetBIOSComputer = objWSHNetwork.ComputerName
Set objWSHNetwork = Nothing
If bDebug Then
e "strNamingContext: " & strNamingContext
e "strConfigContext: " & strConfigContext
e "strNetBIOSDomain: " & strNetBIOSDomain
e "strNetBIOSComputer: " & strNetBIOSComputer
End If
Call InitializeADSI
If GetOrganizationInformation Then
Call ClearSystemInfo
WScript.Quit 1
End If
End Sub
Sub ClearSystemInfo
Call DoneWithADSI
End Sub
Sub CreateHostedUser (ByVal strDomain, _
ByVal strDomainPrefix, _
ByVal strAccountName, _
ByVal strFirstName, _
ByVal strLastName, _
ByVal strPassword, _
ByVal strOAB)
Dim strName ' this will be <firstname> <lastname>, used for CN and displayName
Dim strsAMAccountName ' this will be strDomainPrefix & "_" & strAccountName
Dim strOU ' OU in which to create the user
Dim objParent ' GetObject() of strOU
Dim objUser ' new user object
Dim objExchUser ' CDOEXM object from new user object
Dim iUAC ' value of userAccountControl attribute
On Error Resume Next
strName = strFirstName & " " & strLastName
strsAMAccountName = strDomainPrefix & "_" & strAccountName
strOU = "OU=" & strDomain & "," & OU_HOSTING & "," & strNamingContext
' for examples:
' see KB 304935
' see http://www.rallenhome.com/books/adcookbook/src/06.01-create_user--correction.vbs.txt
'
' EXAMPLE INPUT:
' strDomain = zippy.com
' strDomainPrefix = zip
' strAccountName = info
' strFirstName = John
' strLastName = Doe
' strPassword = z1ppy
' EXAMPLE CALCULATED:
' strName = John Doe
' strsAMAccountName = zip_info
' UPN = info@zippy.com
' strOU = LDAP://OU=zippy.com,OU=Hosting,DC=brnets,DC=local
If bDebug Then
e "Input strDomain: " & strDomain
e "Input strDomainPrefix: " & strDomainPrefix
e "Input strAccountName: " & strAccountName
e "Input strFirstName: " & strFirstName
e "Input strLastName: " & strLastName
e "Input strPassword: " & strPassword
e "Input strOAB: " & strOAB
e "Calc strName: " & strName
e "Calc strsAMAccountName: " & strsAMAccountName
e "Calc UPN: " & strAccountName & "@" & strDomain
e "Calc strOU: " & strOU
e "Calc strTrustee: " & strTrustee
e "Calc strMailboxStoreDN: " & strMailboxStoreDN
e "Calc strOABContainer: " & strOABContainer
e "Const OU_HOSTING: " & OU_HOSTING
End If
Set objParent = GetObject ("LDAP://" & strOU)
If ErrorReport ("on GetObject (" & strOU & ")") Then
Exit Sub
End If Set objUser = objParent.Create ("user", "CN=" & strName)
If ErrorReport ("on Create (CN=" & strName & ")") Then
Exit Sub
End If objUser.Put "sAMAccountName", strsAMAccountName
objUser.Put "userPrincipalName", strAccountName & "@" & strDomain
objUser.Put "givenName", strFirstName
objUser.Put "sn", strLastName
objUser.Put "displayName", strName
objUser.Put "name", strName
objUser.SetInfo
If ErrorReport ("on first SetInfo") Then
Set objUser = Nothing
Exit Sub
End If
objUser.SetPassword (strPassword)
objUser.AccountDisabled = FALSE
objUser.SetInfo
If ErrorReport ("on second SetInfo (Enable Account)") Then
Call objParent.Delete ("user", "CN=" & strName)
Set objUser = Nothing
Exit Sub
End If
' set "Password never expires"
iUAC = objUser.Get ("userAccountControl")
If (iUAC And ADS_UF_DONT_EXPIRE_PASSWD) Then
' already set
Else
iUAC = iUAC XOR ADS_UF_DONT_EXPIRE_PASSWD
End If
objUser.Put "userAccountControl", iUAC
dp "userAccountControl " & iUAC
' set the mailnickname
objUser.mailNickname = strsAMAccountName
' set the OU for OWA to use
objUser.msExchQueryBaseDN = strOU
' set the mail attribute to the UPN (will be overwritten by RUS - see KB 318072)
objUser.Mail = strAccountName & "@" & strDomain
' flush the property cache
objUser.SetInfo
If ErrorReport ("on third SetInfo (userAccountControl, mailNickname, msExchQUeryBaseDN, Mail)") Then
Call objParent.Delete ("user", "CN=" & strName)
Set objUser = Nothing
Exit Sub
End If
' set the OAB for the user (both OWA and Outlook)
objUser.msExchUseOAB = "CN=" & strOAB & "," & strOABContainer
' flush the property cache
objUser.SetInfo
If ErrorReport ("on fourth SetInfo (msExchUseOAB)") Then
Call objParent.Delete ("user", "CN=" & strName)
Set objUser = Nothing
Exit Sub
End If
' add the user to the normal groups for this OU
AddUserToGroup strName, "AllUsers@" & strDomain, strDomain
AddUserToGroup strName, "NormalUsers@" & strDomain, strDomain
' Create the user's mailbox
' Leave this to absolute last, because this is the most
' likely failure point - if this script isn't being run
' on an Exchange server, the Exchange Management Tools must
' be installed.
Set objExchUser = objUser
objExchUser.CreateMailBox strMailboxStoreDN
If ErrorReport ("on CreateMailBox (" & strMailboxStoreDN & ")") Then
'Call objParent.Delete ("user", "CN=" & strName)
Set objUser = Nothing
Exit Sub
End If
objUser.SetInfo
If ErrorReport ("on fifth SetInfo (after CreateMailbox)") Then
Call objParent.Delete ("user", "CN=" & strName)
Set objUser = Nothing
Exit Sub
End If
' update the security on the mailbox
AddNewTrustee objUser
Set objUser = Nothing
End Sub
Sub AddUserToGroup (strName, strGroup, strDomain)
' see http://www.rallenhome.com/books/adcookbook/src/07.04-add_group_member.vbs.txt
Dim strGroupDN, strUserDN
Dim objGroup
On Error Resume Next
If bDebug Then
e "AddUserToGroup strName: " & strName
e "AddUserToGroup strGroup: " & strGroup
e "AdduserToGroup strDomain: " & strDomain
End If
strGroupDN = "LDAP://CN=" & strGroup & ","
strGroupDN = strGroupDN & "OU=" & strDomain & "," & OU_HOSTING & "," & strNamingContext
dp "Calc strGroupDN: " & strGroupDN
Set objGroup = GetObject (strGroupDN)
If ErrorReport ("on GetObject (" & strGroupDN & ")") Then
Exit Sub
End If
strUserDN = "LDAP://CN=" & strName & ","
strUserDN = strUserDN & "OU=" & strDomain & "," & OU_HOSTING & "," & strNamingContext
dp "Calc strUserDN: " & strUserDN
objGroup.Add (strUserDN)
If ErrorReport ("on objGroup.Add (" & strUserDN & ")") Then
Set objGroup = Nothing
Exit Sub
End If
Set objGroup = Nothing
End SUb
Sub AddNewTrustee (objUser)
' see KB 304935
' this code requires Windows XP/Windows Server 2003 or
' Adssecurity.dll to be installed on Windows 2000
Dim objSecurityDescriptor ' SD from msExchMailboxSecurityDescriptor of new user
Dim objDACL ' DiscretionaryACL from SD of msExchMailboxSecurityDescriptor of new user
On Error Resume Next
If Len (strTrustee) = 0 Then
Exit Sub
End If
' Get the copy Mailbox Security Descriptor (SD) stored on the
' msExchMailboxSecurityDescriptor attribute
objUser.GetInfoEx Array ("msExchMailboxSecurityDescriptor"), 0
Set objSecurityDescriptor = objUser.Get ("msExchMailboxSecurityDescriptor")
If ErrorReport ("on Get (msExchMailboxSecurityDescriptor)") Then
Exit Sub
End If
' Extract the Discretionary Access Control List (ACL) using the
' IADsSecurityDescriptor interface
Set objDACL = objSecurityDescriptor.DiscretionaryAcl
' Setting the Access Mask to 131075 enables "full mailbox access" and
' "read" priviledges
AddAce objDACL, strTrustee, 131075, _
ADS_ACETYPE_ACCESS_ALLOWED, ADS_ACEFLAG_INHERIT_ACE, 0, 0, 0
' Add the modified DACL back onto the Security Descriptor
objSecurityDescriptor.DiscretionaryAcl = objDACL
' Save New SD onto the user
objUser.Put "msExchMailboxSecurityDescriptor", objSecurityDescriptor
' Commit changes from the property cache to the information store
objUser.SetInfo
If ErrorReport ("SetInfo (msExchMailboxSecurityDescriptor)") Then
Exit Sub
End If
End Sub
'********************************************************************
'*
'* Function AddAce (dacl, TrusteeName, gAccessMask, gAceType,
'* gAceFlags, gFlags, gObjectType, gInheritedObjectType)
'*
'* Purpose: Adds an ACE to a DACL
'* Input: dacl Object's Discretionary Access Control List
'* TrusteeName SID or Name of the trustee user account
'* gAccessMask Access Permissions
'* gAceType ACE Types
'* gAceFlags Inherit ACEs from the owner of the ACL
'* gFlags ACE has an object type or inherited object type
'* gObjectType Used for Extended Rights
'* gInheritedObjectType
'*
'* Output: Object - New DACL with the ACE added (update dacl param)
'*
'********************************************************************
Function AddAce (dacl, TrusteeName, gAccessMask, _
gAceType, gAceFlags, gFlags, _
gObjectType, gInheritedObjectType)
Dim objACE
On Error Resume Next
' Create a new ACE object
Set objACE = CreateObject ("AccessControlEntry")
If ErrorReport ("CreateObject (AccessControlEntry)") Then
Exit Function
End If
objACE.AccessMask = gAccessMask
objACE.AceType = gAceType
objACE.AceFlags = gAceFlags
objACE.Flags = gFlags
objACE.Trustee = TrusteeName
'Check to see if ObjectType needs to be set
If CStr (gObjectType) <> "0" Then
objACE.ObjectType = gObjectType
End If
'Check to see if InheritedObjectType needs to be set
If CStr (gInheritedObjectType) <> "0" Then
objACE.InheritedObjectType = gInheritedObjectType
End If
dacl.AddAce objACE
' clean up ACE object
Set objACE = Nothing
End Function
Sub e (str)
WScript.Echo str
End Sub
Sub dp (str)
If bDebug Then e str
End Sub
Function ErrorReport (str)
If Err.Number Then
ErrorReport = True
e "Error 0x" & CStr (Hex (Err.Number)) & " occurred " & str
If Err.Description <> "" Then
e "Error description: " & Err.Description
Else
Select Case Err.Number
Case &H80071392
e "Error Description: Object already exists"
Case &H80072030
e "Error Description: No such object"
Case Else
If (Err.Number And &HFFFF0000) = &H80070000 Then
e "Error Description found by: net helpmsg " & _
(Err.Number And 65535)
End If
End Select
End If
Err.Clear
Else
ErrorReport = False
End If
End Function
Sub InitializeADSI
Set Com = WScript.CreateObject ("ADODB.Command")
Set Conn = WScript.CreateObject ("ADODB.Connection")
' Open the connection.
Conn.Provider = "ADsDSOObject"
Conn.Open "ADs Provider"
End Sub
Sub DoneWithADSI
Conn.Close
Set Com = Nothing
Set Conn = Nothing
End Sub
Sub DoLDAPQuery (strLDAPQuery, resultSet)
Com.ActiveConnection = Conn
Com.CommandText = strLDAPQuery
Set resultSet = Com.Execute
End Sub
Sub FinishLDAPQuery (resultSet)
resultSet.Close
Set resultSet = Nothing
End Sub
Function GetOrganizationInformation
Dim strQuery
GetOrganizationInformation = False
' Build a query to find the Exchange organization.
strQuery = "<LDAP://" & strConfigContext & ">;" & _
"(objectCategory=msExchOrganizationContainer);" & _
"name,distinguishedName;" & _
"subtree"
strOrgDN = ""
Call DoLDAPQuery (strQuery, Rs)
' If there are any results, there will only be one result. There
' may only be one Exchange organization per Active Directory forest.
e "Exchange Organization Name: " & Rs.Fields ("name")
If bDebug Then e "Organization DN: " & Rs.Fields ("distinguishedName")
strOrgDN = Rs.Fields ("distinguishedName") Call FinishLDAPQuery (rs)
If Len (strOrgDN) = 0 Then
e "Cannot find Exchange organization information"
GetOrganizationInformation = True
End If
End Function
Sub GetAllServers
Dim strQuery
' Now, get the list of all servers within the organization
strQuery = "<LDAP://" & strOrgDN & ">;(objectCategory=msExchExchangeServer);name,cn,distinguishedName;subtree"
strServerList = ""
strServerListDN = ""
Call DoLDAPQuery (strQuery, Rs)
e "All Exchange Servers in forest " & strNamingContext
While Not Rs.EOF
' output the current server found
dp "Server CN: " & Rs.Fields ("cn")
e "Server Name: " & Rs.Fields ("name")
dp "Server DN: " & Rs.Fields ("distinguishedName")
If strServerList = "" Then
strServerList = Rs.Fields ("name")
strServerListDN = Rs.Fields ("distinguishedName")
Else
strServerList = strServerList & ";" & Rs.Fields ("name")
strServerListDN = strServerListDN & ";" & Rs.Fields ("distinguishedName")
End If
Rs.MoveNext
Wend
Call FinishLDAPQuery (Rs)
' Report our results
dp "strServerList = " & strServerList
dp "strServerListDN = " & strServerListDN
End Sub
Function FindServer (str)
Dim arrServers
Dim i
arrServers = Split (strServerList, ";")
For i = LBound (arrServers) to UBound (arrServers)
If LCase (str) = LCase (arrServers (i)) Then
FindServer = True
Exit Function
End If
Next
FindServer = False
End Function
Sub GetAllOfflineAddressLists
Dim strQuery
Dim str
' DN to Offline Address Lists container
str = "CN=Offline Address Lists,CN=Address Lists Container," & strOrgDN
' Now, get the list of all offline address lists within the organization
strQuery = "<LDAP://" & str& ">;(objectCategory=msExchOAB);name;subtree"
strOALList = ""
Call DoLDAPQuery (strQuery, Rs)
e "All OALs in DN " & str
While Not Rs.EOF
' e "OAL Name: " & Rs.Fields ("name")
If strOALList = "" Then
strOALList = Rs.Fields ("name")
Else
strOALList = strOALList & ";" & Rs.Fields ("name")
End If
Rs.MoveNext
Wend
Call FinishLDAPQuery (Rs)
' Report our results
dp "strOALList = " & strOALList
End Sub
Function FindOAL (str)
Dim arrOAL
Dim i
arrOAL = Split (strOALList, ";")
For i = LBound (arrOAL) to UBound (arrOAL)
If LCase (str) = LCase (arrOAL (i)) Then
FindOAL = True
Exit Function
End If
Next
FindOAL = False
End Function
' Thanks to Andy Webb for this idea
Function IsExchangeManagementInstalled
Dim objWMIService
Dim colItems, objItem
Dim strComputer
strComputer = "."
Set objWMIService = GetObject ("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery ("SELECT * FROM Win32_Service where Caption='Microsoft Exchange Management'", "WQL", _
wbemFlagReturnImmediately + wbemFlagForwardOnly) ' if we get any items returned, it's installed
For Each objItem In colItems
IsExchangeManagementInstalled = True
dp "Exchange Management is installed"
Set colItems = Nothing
Set objWMIService = Nothing
Exit Function
Next
Set colItems = Nothing
Set objWMIService = Nothing
dp "Exchange Management is NOT installed"
IsExchangeManagementInstalled = False
End Function