Создание пользователей Exchange в Excel (Часть 2)

В этой статье мы обсудим решение основных проблем, а также синхронизацию Excel с Active Directory.

Если вы пропустили первую часть статьи, пожалуйста, прочтите:

Создание пользователей Exchange в Excel (Часть 1)

Вступление

В предыдущей части статьи мы поняли, как, используя VBA, сэкономить время, затрачиваемое на добавление пользователей в Active Directory и создания почтовых ящиков для них. Однако, есть небольшие ограничения в использование такого скрипта, так как некоторые поля становятся доступными только после отметки Exchange RUS. К тому же скрипт узконацеленный и одноразовый. В этой статье я расскажу, как решить эту проблему и как синхронизировать Excel с Active Directory.

Активация RUS

Помните студента из первой части статьи?

Рисунок 1

Вторая колонка содержит социальный номер обеспечения студента. Я решил использовать в описание атрибут пользователя. Однако, так как описание – полезное поле, которое я могу использовать для идентификации учителей и прочих работников школы, я решил переместить социальный номер обеспечения в начальный Расширенный Атрибут пользователя, пометить его основным, extensionAttribute1.

И хотя этот атрибут присваивается всем пользователям и соответствует схемам Exchange, вы не сможете использовать ее до тех пор, пока не появится отметка RUS, разрешающая этот атрибут.

К счастью, мы можем решить эту проблему. Проще всего это сделать в одиночной среде Exchange, где процесс управления и дублирования ускорении и упрощен. В более сложной среде в скрипте вам придется указывать доменный контроллер, используемый RUS.

Давайте присмотримся к этому коду:

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 = ";(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

Это сценарий пускает RUS так, что бы пользователи могли быть отмеченными. Теперь вы можете скомбинировать этот код с любым вашим скриптом создания или макросом Excel так, что бы пользователи получали отметку почти мгновенно. Это все конечно хорошо, но может вызвать настоящую головную боль в том случае, если у вас огромный сервер Exchange, включающий тысячи пользователей. Вы можете выставить время ожидания, используя команду WScript.Sleep (измеряется в миллисекундах)

Либо же мы можем убрать следующую строку из нашего скрипта:

oUser.Put "description", ID

И добавить FireRUS подпрограмму в конце нашего скрипта. Или просто запустить ее отдельно. Теперь скрипт будет выглядеть так:

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 = ";(&(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 = ";(&(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

Обратите внимание, что я добавил несколько строк кода в середине скрипта, чтобы заполнить адрес пользователя. Эта информация поможет второй макрокоманде определять местонахождение пользователя.

Добавление атрибута пользователям

Второй Macro читает ячейки Excel так же, как и до этого, но вместо того, что бы создавать пользователей, он ищет их по имени и адресу. Когда он находит пользователя, он просто добавляет ID номер к пользовательскому атрибуту объекта ExtensionAtttribute1.

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 = ";(&(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

Синхронизация пользователей

Полученный скрипт довольно прост, но мы можем использовать его как основу для скрипта синхронизации. Если мы можем найти пользователя, то почему бы не использовать это в наших целях? Например, создать пользователя в случае его отсутствия или обновить информацию о нем?

Давайте добавим другого пользователя и и немного изменим информацию в документе Excel:

Рисунок 2

Я добавил пользователя и изменил индекс старого.

Теперь, все, что мне нужно, так это соединить старый скрипт с новым.

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 = ";(&(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 = ";(&(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 = ";(&(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

Как и раньше, скрипт проверит все строки, но на этот раз он внесет не существующие. Но это еще не полная синхронизация, так как ExtensionAttribue1 обновится лишь со второй частью скрипта. И, если у вас есть возможность пускать это скрипт каждую пару часов, то вы получаете полную синхронизацию.

Заключение

Мы создали механизм, синхронизирующий Active Directory используя листы Excel. Это открывает массу новых возможностей. Вы можете использовать секретарей, которые будут заполнять лист Excel, даже не имея представления об Active Directory, но заполняя ее по сути. Вы можете выполнить все виды проверок на листе Excel перед вводом данных в Активный Каталог. Вы можете импортировать данные из любого источника в Excel, а оттуда и в Active Directory. В конце концов, очень многие приложения, даже очень старые, могут экспортировать данные в CSV или табулированный текстовый файл, с легкостью читаемый Excel.

Так же, из соображений безопасности, вы можете импортировать информацию из разделенных систем, не имеющих между собой никакой связи. И все благодаря простоте Excel и магическому скрипту.