If you missed the first part in this article series please read Creating Exchange Users with Excel (Part 1).

Introduction

In the previous article I showed how using VBA can save you time when bulk adding users into Active Directory and creating Exchange mailboxes for them. However, there are some limitations to that script because some fields only become available when the mailbox is stamped by the Exchange RUS. Also, the script is a one way, a one time deal. In this article I will show you how to overcome those problems and how to synchronize an Excel sheet with Active Directory.

Activating the RUS

Remember the student list we had in the previous article?

Figure 1

The second column contained the social security number of the student. I decided to put in the description attribute of the user. However, since the description is a useful field that I can use for identifying roles of teachers and other school workers, let's decide now to move the social security number to the first Extension Attribute of the user, extensionAttribute1.

Though this attribute supposedly exists for all users once the schema has been extended for Exchange use, you won't be able to set it unless the user has been stamped by the RUS, enabling this attribute.

Luckily for us, we can help speed this process up. This works best in a single Exchange environment where user management and replication is fast and easy. In a more complex environment the script should point to the domain controller which the RUS uses.

Let's look closely at the following code:

Sub FireRUS
'Activate the RUS stamping

Dim RootDse
Set RootDse = GetObject(LDAP://RootDSE)
strdn = RootDse.Get("defaultNamingContext")
strDomainName = "DOMAIN"
strConfigurationNC = RootDse.Get("ConfigurationNamingContext")
strExchangeOrg = FindAnyOrg(strConfigurationNC)
strRUS = "CN=Recipient Update Service (" & strDomainName & "),CN=Recipient Update Services," & _
            "CN=Address Lists Container,CN=" & strExchangeOrg & ",CN=Microsoft Exchange,CN=Services," & _
         "CN=Configuration," & strdn
Set objRUS = GetObject("LDAP://" & strRUS)
objRUS.Put "msExchReplicateNow", True
objRUS.SetInfo

End Sub

Function FindAnyOrg(strConfigurationNC)
Set oConnection = CreateObject("ADODB.Connection")
   Set oCommand = CreateObject("ADODB.Command")
   Set oRecordSet = CreateObject("ADODB.RecordSet")
   Dim strQuery

   ' Open the Connection
   oConnection.Provider = "ADsDSOObject"
   oConnection.Open "ADs Provider"
   ' Build the query to find the private Exchange Organization
   strQuery = "<LDAP://" & strConfigurationNC & ">;(objectCategory=msExchOrganizationContainer);name,adspath;subtree"
   oCommand.ActiveConnection = oConnection
   oCommand.CommandText = strQuery
   Set oRecordSet = oCommand.Execute

   ' If we have an Organization then return the first one
   If Not oRecordSet.EOF Then
     oRecordSet.MoveFirst
     FindAnyOrg = CStr(oRecordSet.Fields("name").Value)
   Else
     FindAnyOrg = ""
   End If

   'Clean Up
   oRecordSet.Close
   oConnection.Close
   Set oRecordSet = Nothing
   Set oCommand = Nothing
   Set oConnection = Nothing
End Function

This script fires up the RUS so that users get stamped. Now you can combine this with any of our user creation scripts or Excel macros so that the users get stamped almost immediately. This is all very well but can be quite hefty in large Exchange servers with thousands of users. You can specify a waiting period using the WScript.Sleep command (the time specified is in milliseconds). Still if you add 4000 users you wouldn't want the RUS to run 4000 times, especially in a large environment.

Instead we can remove the following line from our script:

    oUser.Put "description", ID

And add the FireRUS subroutine at the end of the script or simply run it separately. Now the script will look like this:

Sub CreateUsers()

Dim Row As Integer
Dim oMailbox As CDOEXM.IMailboxStore
Dim oUser As IADsUser

Set rootDSE = GetObject(LDAP://RootDSE)
DomainContainer = rootDSE.Get("defaultNamingContext")
Set oOU = GetObject(LDAP://OU=Test,DC=mycompany,DC=local)

Row = 1

Do Until Cells(Row, 1) = Empty
    gname = Trim(Cells(Row, 1).Value)
    sname = Trim(Cells(Row, 2).Value)
    ID = Cells(Row, 3).Value
    mailingaddress = Cells(Row, 4).Value
    city = Cells(Row, 5).Value
    postalcode = Cells(Row, 6).Value
    homephone = Cells(Row, 7).Value
    cellular = Cells(Row, 8).Value
    dept = Trim(Cells(Row, 9).Value)

    FullName = gname & " " & sname

    AliasCount = 2
    Alias = LCase(gname & Left(sname, AliasCount))

    Set conn = CreateObject("ADODB.Connection")
    conn.Provider = "ADSDSOObject"
    conn.Open "ADs Provider"

    ldapStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)(mailNickname=" & Alias & "));adspath;subtree"

    Set rs = conn.Execute(ldapStr)

    While rs.RecordCount > 0
      AliasCount = AliasCount + 1
      Alias = LCase(gname & Left(sname, AliasCount))
      ldapStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)(mailNickname=" & Alias & "));adspath;subtree"
      Set rs = conn.Execute(ldapStr)

   Wend
    ' Update User Record
    Set oUser = oOU.Create("user", "cn=" & FullName)
    oUser.Put "cn", FullName
    oUser.Put "SamAccountName", Alias
    oUser.Put "userPrincipalName", Alias & "@mycompany.local"
    oUser.Put "givenName", gname
    oUser.Put "sn", sname
    oUser.Put "streetaddress", mailingaddress
    oUser.Put "l", city 
    oUser.Put "postalCode" , CStr (postalcode)

    oUser.SetInfo
    oUser.GetInfo

    ' Enable Account
    oUser.AccountDisabled = False
    ' Set Pwd to be same as 123456
    oUser.SetPassword ("123456")
    'Account is not disabled
    oUser.AccountDisabled = False
    ' User must change password at next Logon
    oUser.Put "pwdLastSet", CLng(0)

    oUser.SetInfo 

    Set oMailbox = oUser
    MDBName = "Mailbox Store (EXCHANGE)"
    StorageGroup = "First Storage Group"
    Server = "Exchange"
    AdminGroup = "MyCompany"
    Organization = "MyCompany School of Arts"
    DomainDN = "DC=mycompany,DC=local"

    oMailbox.CreateMailbox "LDAP://CN=" & MDBName & _
                                   ",CN=" & StorageGroup & _
                                   ",CN=InformationStore" & _
                                   ",CN=" & Server & _
                                   ",CN=Servers" & _
                                   ",CN=" & AdminGroup & _
                                   ",CN=Administrative Groups" & _
                                   ",CN=" & Organization & _
                                   ",CN=Microsoft Exchange,CN=Services" & _
                                   ",CN=Configuration," & DomainDN

    oUser.SetInfo

    StrobjGroup1 = "LDAP://CN=" & dept & ",OU=Test,DC=mycompany,DC=local"
    Set objGroup1 = GetObject(StrobjGroup1)
    objGroup1.Add (oUser.ADsPath)

    Set oUser = Nothing
    Row = Row + 1
Loop

FireRUS
End Sub

Notice that I added a few lines in the middle of the script to populate the user's address. This information will help the second macro locate the user.

Adding the Attribute to the Users

The second Macro reads the Excel cells as before, but instead of creating the user it searches for an existing one using the user's name and address. When it locates the user, it simply adds the ID number to the user object ExtensionAtttribute1 attribute.

Sub AddExtensionAttribute1()

Dim Row As Integer
Dim oUser As IADsUser

Set RootDse = GetObject(LDAP://RootDSE)
DomainContainer = RootDse.Get("defaultNamingContext")
Set oOU = GetObject(LDAP://OU=Test,DC=domain,DC=local)

Set conn = CreateObject("ADODB.Connection")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"

Row = 1

Do Until Cells(Row, 1) = Empty
    gname = Trim(Cells(Row, 1).Value)
    sname = Trim(Cells(Row, 2).Value)
    ID = Cells(Row, 3).Value
    mailingaddress = Cells(Row, 4).Value
    city = Cells(Row, 5).Value
    postalcode = Cells(Row, 6).Value
    homephone = Cells(Row, 7).Value
    cellular = Cells(Row, 8).Value
    dept = Trim(Cells(Row, 9).Value)
'Construct an LDAP query to Active Directory looking for users with the specified attributed,
'first name, last name, address, etc.
    LDAPStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)(givenName=" & gname & ")(sn=" & sname & ")(streetaddress=" & mailingaddress & ")(l=" & city & "));adspath;subtree"

         Set rs = conn.Execute(LDAPStr)
'If there is more than one user found – and there supposed to be just one
        If rs.RecordCount > 0 Then
'Populate the Exchange extension attribute no.1
            Set oUser = GetObject(rs.Fields(0).Value)
            oUser.Put "extensionAttribute1", ID
        oUser.SetInfo
        End If

    Set oUser = Nothing
    Set rs = Nothing
    Row = Row + 1
Loop

End Sub

Synchronizing Users

The script above is pretty simple yet we can use it as a base for a synchronization script. If we can locate a user, why not use this to our advantage and create a user if it is not found, or update a user's record?

Let's add another user and change some information on our Excel sheet:

Figure 2

I added a new user and changed the zip code for another.

Now all we need to do is combine the first and second script.

Sub SyncUsers()

Dim Row As Integer
Dim oMailbox As CDOEXM.IMailboxStore
Dim oUser As IADsUser

Set RootDse = GetObject(LDAP://RootDSE)
DomainContainer = RootDse.Get("defaultNamingContext")
Set oOU = GetObject(LDAP://OU=Test,DC=domain,DC=local)

Set conn = CreateObject("ADODB.Connection")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"

Row = 1

Do Until Cells(Row, 1) = Empty

    gname = Trim(Cells(Row, 1).Value)
    sname = Trim(Cells(Row, 2).Value)
    ID = Cells(Row, 3).Value
    mailingaddress = Cells(Row, 4).Value
    city = Cells(Row, 5).Value
    postalcode = Cells(Row, 6).Value
    homephone = Cells(Row, 7).Value
    cellular = Cells(Row, 8).Value
    dept = Trim(Cells(Row, 9).Value)
    LDAPStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)(givenName=" & gname & ")(sn=" & sname & ")(streetaddress=" & mailingaddress & ")(l=" & city & "));adspath;subtree"

         Set rs = conn.Execute(LDAPStr)
    If rs.RecordCount > 0 Then
        Set oUser = GetObject(rs.Fields(0).Value)
       oUser.Put "streetaddress", mailingaddress
       oUser.Put "l", city
       oUser.Put "postalCode", CStr(postalcode)
       oUser.Put "extensionAttribute1", ID
       oUser.SetInfo

    Else
    'If Record Count is zero because no user is found    
       FullName = gname & " " & sname
       AliasCount = 2
       Alias = LCase(gname & Left(sname, AliasCount))
       Set conn = CreateObject("ADODB.Connection")
       conn.Provider = "ADSDSOObject"
       conn.Open "ADs Provider"

       LDAPStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)(mailNickname=" & Alias & "));adspath;subtree"

       Set rs = conn.Execute(LDAPStr)

       While rs.RecordCount > 0
         AliasCount = AliasCount + 1
         Alias = LCase(gname & Left(sname, AliasCount))
         LDAPStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=user)(mailNickname=" & Alias & "));adspath;subtree"
         Set rs = conn.Execute(LDAPStr)

       Wend
       ' Update User Record
       Set oUser = oOU.Create("user", "cn=" & FullName)
       oUser.Put "cn", FullName
       oUser.Put "SamAccountName", Alias
       oUser.Put "userPrincipalName", Alias & "@domain.local"
       oUser.Put "givenName", gname
       oUser.Put "sn", sname

        oUser.SetInfo
       oUser.GetInfo

       oUser.Put "streetaddress", mailingaddress
       oUser.Put "l", city
       oUser.Put "postalCode", CStr(postalcode)
       oUser.SetPassword "123456"
       oUser.AccountDisabled = False

       oUser.SetInfo

       Set oMailbox = oUser
       MDBName = "Mailbox Store (EXCHANGE)"
       StorageGroup = "First Storage Group"
       Server = "Exchange"
       AdminGroup = "AG"
       Organization = "Org"
       DomainDN = "DC=domain,DC=local"

       oMailbox.CreateMailbox "LDAP://CN=" & MDBName & _
                                      ",CN=" & StorageGroup & _
                                      ",CN=InformationStore" & _
                                      ",CN=" & Server & _
                                      ",CN=Servers" & _
                                      ",CN=" & AdminGroup & _
                                      ",CN=Administrative Groups" & _
                                      ",CN=" & Organization & _
                                      ",CN=Microsoft Exchange,CN=Services" & _
                                      ",CN=Configuration," & DomainDN

       oUser.SetInfo

       ' Enable Account
       oUser.AccountDisabled = False
       ' Set Pwd to be same as user name/alias
       oUser.SetPassword ("123456")
       ' User must change password at next Logon
       oUser.Put "pwdLastSet", CLng(0)
       oUser.SetInfo
       StrobjGroup1 = "LDAP://CN=" & dept & ",OU=Test,DC=domain,DC=local"
       Set objGroup1 = GetObject(StrobjGroup1)
       objGroup1.Add (oUser.ADsPath)

       Set oUser = Nothing

   End If
   Row = Row + 1
Loop
FireRUS
Exit Sub

End Sub

The script goes through all the rows as before but if it finds a user that does not exist, it creates it. This does not perform full synchronization as ExtensionAttribue1 will only get updated during the second run of the script. However, if you run this script using a scheduler every few hours you will eventually get full synchronization.

Conclusion

We've established a mechanism that we can use to synchronize Active Directory using an Excel sheet. This opens up possibilities. You could have HR or secretaries edit this sheet without them having to learn how to use Active Directory Users and Computers and possibly without granting them any actual permissions. You can run all sorts of checks on an Excel sheet before entering the data into Active Directory. You can import information from another system into Excel and from there populate Active Directory. After all, most applications, even old ones can export to a CSV or Tab Separated text file which can be read by Excel.

You can also import information from separate systems that have no direct connections between them due to security reasons, because all you need is to transfer an Excel sheet and work some scripting magic.

If you missed the first part in this article series please read Creating Exchange Users with Excel (Part 1).