Карточка сотрудника Active Directory через Excel

Карточка сотрудника Active Directory через Excel

Знакомство с темой

Продолжим наше знакомство с Excel через призму сетевых технологий. 

Наша сегодняшняя тема будет рассматривать возможность отображения каких либо данных из Active Directory в выходные формы Excel.  Для чего же нам нужно?  Самый простая задача которая требудет  прочтения этой статьи.

Руководитель поставил задачу создать красивый отчет по всем сотрудникам которые работают в корпоративной сети ( под управлением Active Directory). 

То есть на каждого сотрудника должна быть карточка формата А4, в которой будут заполнены ФИО, должность, комната, все его телефоны и так далее.

Карточка должна быть раскрашена в корпоративном цвете и определенной шапкой в заголовке.

Так как  дураков нет, то поручили её вам, как администратору сети :) ( у нас именно так.. все нерешаемые вопросы в компании, которые не требуют административного решения, стекаются в отдел ИТ)

Какие же есть варианты решения. В большинстве, вариант простой - делается экспорт всех пользователей домена в csv формат, а дальше разбирается и на основе экспортированных данных  строится та карточка сотрудника компании которая необходима.

Есть немного другой принцип, он отличается тем что получаемые данные  в карточке всегда актуальны, а не только на дату экспортированного файла.

Мы рассматривали POST запрос через Excel пойдем по этому же пути, с небольшими расширениями и уточнениями.

Не могу не воспользоваться что бы  в очередной раз сказать свое "фи" компании Микрософт,  по поводу отсутствия встроенного парсера JSON в Excel.

Об Active Directory

Мы не будем рассматривать  общуюю концепцию Active Directory, откуда появилась и прочее. Скажем лишь одно, что эта она из реализаций протокола LDAP, взятой компанией Microsoft  на вооружение при создании операционной системой.

А раз так то, то все что применимо для протокола LDAP применимо и для работы с AD.

Если мы возьмем бесплатную программу для просмотра и редактирования LDAP аттрибутов (Apache Directory Studio) и подключимся к контроллеру домена, то нам откроется огромный мир аттрибутов и их значений, которые обычно скрыты стандартными программами, и недоступны для пользователей и администраторов.

Вот  только лишь часть тех аттрибутов, которые существуют в моей сети у каждого пользователя.

memberOf

objectClass

cn
instanceType
objectCategory
accountExpires
badPasswordTime
badPwdCount
codePage
company
countryCode
department
displayName
distinguishedName
dSCorePropagationData
extensionAttribute1
extensionAttribute2
extensionAttribute3
extensionAttribute4
extensionAttribute5
extensionAttribute9
givenName
homeMDB
homeMTA
info
ipPhone
l
lastLogoff
lastLogon
lastLogonTimestamp
legacyExchangeDN
logonCount
mail
mailNickname
managedObjects
mDBUseDefaults
mobile
msDS-AuthenticatedAtDC
msExchDelegateListBL
msExchDelegateListLink
msExchHomeServerName
msExchMailboxGuid
msExchMailboxSecurityDescriptor
msExchMobileMailboxFlags
msExchPoliciesIncluded
msExchRBACPolicyLink
msExchRecipientDisplayType
msExchRecipientTypeDetails
msExchTextMessagingState
msExchUMDtmfMap
msExchUserAccountControl
msExchUserCulture
msExchVersion
msExchWhenMailboxCreated
name
objectGUID
objectSid
physicalDeliveryOfficeName
postalCode
primaryGroupID
proxyAddresses
pwdLastSet
sAMAccountName
sAMAccountType
showInAddressBook
sn
st
streetAddress
telephoneNumber
title
userAccountControl
userPrincipalName
uSNChanged
uSNCreated
whenChanged
whenCreated
 
Здесь и данные когда была создана учетная запись и типовые данные пользователя ( должность, телефон, ФИО, отдел и прочее) и информация отключена ли эта учетная запись или нет ( за это отвечает userAccountControl) и многое другое.
Обладая такой полной информацией по другому понимаешь, структуру данных, что можно делать с AD, и как можно её расширять и дополнять.
 

запрос через Excel учетных данный пользователя

Функция, которая позволяет  работать с данными Active Directory следующая:

Function jsonxx(key, body, point)
Dim sURL As String
Dim oHttp As Object
Dim result                            As String
Set oHttp = CreateObject("MSXML2.ServerXMLHTTP")
sURL = "http://ваш сервер/ваш скрипт"
oHttp.Open "POST", sURL, False
oHttp.setrequestheader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
oHttp.setrequestheader "Content-Type", "application/x-www-form-urlencoded"
oHttp.send ("from=www&key=" + key + "&body=" + body + ";" + point)
result = oHttp.ResponseText
Dim jsonlib                         As New jsonlib 'class name you give it
Set oContracts = jsonlib.parse(CStr(result))
ff = oContracts("result")
jsonxx = ff
End Function
 
Сначала мы формируем POST запрос нашему боту с необходимыми параметрами: Адресом страницы где обитает бот(http://ваш сервер/ваш скрипт), необходимыми заголовками oHttp.setrequestheader, и непосредственно замим запросом который содержит необходимые ключи и входные данные oHttp.send ("from=www&key=" + KEY + "&body=" + body)
 
Адрес, где будет обитать ваш бот, можете указать любой. 
 
Dim sURL As String
Dim oHttp As Object
Set oHttp = CreateObject("MSXML2.ServerXMLHTTP")
sURL = "http://ваш сервер/ваш скрипт"
oHttp.Open "POST", sURL, False
oHttp.setrequestheader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
oHttp.setrequestheader "Content-Type", "application/x-www-form-urlencoded"
oHttp.send ("from=www&key=" + KEY + "&body=" + body)
result = oHttp.ResponseText
 
Получаем ответ от сервера в переменную result = oHttp.ResponseText
 
Ответом является строка в формате JSON и для того чтобы мы могли её быстро разобрать на составялющие, внедрим в Excel библиотеку jsonlib (листинг которой представлен в самом конце этой статьи)
И вызовем эту библиотеку
 
Dim jsonlib                         As New jsonlib 'class name you give it
Set oContracts = jsonlib.parse(CStr(result))
ff = oContracts("result")
 
Мы получили в переменной наш ответ.
 
И мы совсем забыли о том что же являются входными данными для этой функции
 
Function jsonxx(key, body, point)
key - ключ, для этого бота, когда был создан  и протетстирован  имел имя people (сейчас заблокирован, ибо незачем светить данные сотрудников компании)
body - часть фамилии сотрудника
point -  значения какого аттрибута вернуть  пользователю. Если там sn - то это фамилия, если city - город, если titie - то должность сотрудника
 

Листинг серверной части на языке PHP

 
Это как раз ваш скрипт, который должне размещаться на вашем сервере :)
 
function people($info,$trig) {
global $json_info;
$arr=preg_split('/\;/', $info);
$info=trim(ereg_replace(" +"," ",$arr[0]));
$key=trim(ereg_replace(" +","",$arr[1]));
$ldaprdn  = 'имя администратора каталога';     // ldap rdn или dn
$ldappass = 'Пароль администратора каталога ';  // ассоциированный пароль
$ldapconn = ldap_connect("IP адрес сервера")
    or die("Не могу соединиться с сервером LDAP.");
if ($ldapconn) {
    $ldapbind = ldap_bind($ldapconn, $ldaprdn, $ldappass);
    if ($ldapbind) {
//        echo "LDAP-привязка успешна...";
    } else {
//        echo "LDAP-привязка не удалась...";
    }
}
ldap_set_option($ldapconn, LDAP_OPT_PROTOCOL_VERSION, 3);
$dn = "DN сервера или в нашем конректном примере, уровень иерархии каталога LDAP откуда начнем искать совпадения по фильтру";
$filter='(&(displayName='.@iconv("UTF-8", "WINDOWS-1251",$info).'*)(objectClass=person))';
// так как имя вводим в UTF кодировке а в Active Directory хранятся в кодировке Windows, то осуществлем переконвертацию
$sr=ldap_search($ldapconn, $dn, $filter);
$infa = ldap_get_entries($ldapconn, $sr);
//print_r($infa);
foreach ($infa as $value) {
$result=iconv("WINDOWS-1251","UTF-8",$value[$key][0]);
}
$msg="\r\nИмя пользователя: \r\n".$result;
$str_out=array('info'=>$info,'msg'=>$msg,'result'=>$result);
stream_out($str_out,$trig);
}
 
Функция взята с рабочего процеса, и поэтому "не причесана". Сама суть для большинства понятна и не требует подробных разъяснений.
 

Предварительные выводы

 
Как Вы поняли нет ничего сложного получать данные из каталога LDAP в Excel для  дальнейшей работы в режиме онлайн.  При необходимой сноровке,  через Excel можно модифицировать  значения аттрибутов, что иногда  удобнее чем через ВЕБ форму. Например - редактирование телефонных справочников компании. Причем меняется только скрипт который на стороне сервера,  что бы он мог не только читать данные  из каталога, но еще и записывать данные в него.
 
На этом знакомство Excel  и JSON запросов завершим, и перейдем  к написанию других интересных статей.
 

 

Листинг бибилиотеки Excel jsonlib

Option Explicit
 
Const INVALID_JSON      As Long = 1
Const INVALID_OBJECT    As Long = 2
Const INVALID_ARRAY     As Long = 3
Const INVALID_BOOLEAN   As Long = 4
Const INVALID_NULL      As Long = 5
Const INVALID_KEY       As Long = 6
 
Private Sub Class_Initialize()
 
End Sub
 
Private Sub Class_Terminate()
 
End Sub
 
'
'   parse string and create JSON object (Dictionary or Collection in VB)
'
Public Function parse(ByRef str As String) As Object
 
    Dim index As Long
    index = 1
    
    On Error Resume Next
 
    Call skipChar(str, index)
    Select Case Mid(str, index, 1)
    Case "{"
        Set parse = parseObject(str, index)
    Case "["
        Set parse = parseArray(str, index)
    End Select
 
End Function
 
'
'   parse collection of key/value (Dictionary in VB)
'
Private Function parseObject(ByRef str As String, ByRef index As Long) As Object
 
    Set parseObject = CreateObject("Scripting.Dictionary")
    
    ' "{"
    Call skipChar(str, index)
    If Mid(str, index, 1) <> "{" Then Err.Raise vbObjectError + INVALID_OBJECT, Description:="char " & index & " : " & Mid(str, index)
    index = index + 1
    
    Do
    
        Call skipChar(str, index)
        If "}" = Mid(str, index, 1) Then
            index = index + 1
            Exit Do
        ElseIf "," = Mid(str, index, 1) Then
            index = index + 1
            Call skipChar(str, index)
        End If
        
        Dim key As String
        
        ' add key/value pair
        parseObject.Add key:=parseKey(str, index), Item:=parseValue(str, index)
        
    Loop
 
End Function
 
'
'   parse list (Collection in VB)
'
Private Function parseArray(ByRef str As String, ByRef index As Long) As Collection
 
    Set parseArray = New Collection
    
    ' "["
    Call skipChar(str, index)
    If Mid(str, index, 1) <> "[" Then Err.Raise vbObjectError + INVALID_ARRAY, Description:="char " & index & " : " + Mid(str, index)
    index = index + 1
    
    Do
        
        Call skipChar(str, index)
        If "]" = Mid(str, index, 1) Then
            index = index + 1
            Exit Do
        ElseIf "," = Mid(str, index, 1) Then
            index = index + 1
            Call skipChar(str, index)
        End If
        
        ' add value
        parseArray.Add parseValue(str, index)
        
    Loop
 
End Function
 
'
'   parse string / number / object / array / true / false / null
'
Private Function parseValue(ByRef str As String, ByRef index As Long)
 
    Call skipChar(str, index)
    
    Select Case Mid(str, index, 1)
    Case "{"
        Set parseValue = parseObject(str, index)
    Case "["
        Set parseValue = parseArray(str, index)
    Case """", "'"
        parseValue = parseString(str, index)
    Case "t", "f"
        parseValue = parseBoolean(str, index)
    Case "n"
        parseValue = parseNull(str, index)
    Case Else
        parseValue = parseNumber(str, index)
    End Select
 
End Function
 
'
'   parse string
'
Private Function parseString(ByRef str As String, ByRef index As Long) As String
 
    Dim quote   As String
    Dim char    As String
    Dim code    As String
    
    Call skipChar(str, index)
    quote = Mid(str, index, 1)
    index = index + 1
    Do While index > 0 And index <= Len(str)
        char = Mid(str, index, 1)
        Select Case (char)
        Case "\"
            index = index + 1
            char = Mid(str, index, 1)
            Select Case (char)
            Case """", "\\", "/"
                parseString = parseString & char
                index = index + 1
            Case "b"
                parseString = parseString & vbBack
                index = index + 1
            Case "f"
                parseString = parseString & vbFormFeed
                index = index + 1
            Case "n"
                parseString = parseString & vbNewLine
                index = index + 1
            Case "r"
                parseString = parseString & vbCr
                index = index + 1
            Case "t"
                parseString = parseString & vbTab
                index = index + 1
            Case "u"
                index = index + 1
                code = Mid(str, index, 4)
                parseString = parseString & ChrW(Val("&h" + code))
                index = index + 4
            End Select
        Case quote
            index = index + 1
            Exit Function
        Case Else
            parseString = parseString & char
            index = index + 1
        End Select
    Loop
 
End Function
 
'
'   parse number
'
Private Function parseNumber(ByRef str As String, ByRef index As Long)
 
    Dim value   As String
    Dim char    As String
    
    Call skipChar(str, index)
    Do While index > 0 And index <= Len(str)
        char = Mid(str, index, 1)
        If InStr("+-0123456789.eE", char) Then
            value = value & char
            index = index + 1
        Else
            'some parts commented out here. It incorrectly converted to Int, which caused errors for high numbers
            'If InStr(value, ".") Or InStr(value, "e") Or InStr(value, "E") Then
                parseNumber = CDbl(value)
            'Else
            '    parseNumber = CInt(value)
            'End If
            Exit Function
        End If
    Loop
 
 
End Function
 
'
'   parse true / false
'
Private Function parseBoolean(ByRef str As String, ByRef index As Long) As Boolean
 
    Call skipChar(str, index)
    If Mid(str, index, 4) = "true" Then
        parseBoolean = True
        index = index + 4
    ElseIf Mid(str, index, 5) = "false" Then
        parseBoolean = False
        index = index + 5
    Else
        Err.Raise vbObjectError + INVALID_BOOLEAN, Description:="char " & index & " : " & Mid(str, index)
    End If
 
End Function
 
'
'   parse null
'
Private Function parseNull(ByRef str As String, ByRef index As Long)
 
    Call skipChar(str, index)
    If Mid(str, index, 4) = "null" Then
        parseNull = Null
        index = index + 4
    Else
        Err.Raise vbObjectError + INVALID_NULL, Description:="char " & index & " : " & Mid(str, index)
    End If
 
End Function
 
Private Function parseKey(ByRef str As String, ByRef index As Long) As String
 
    Dim dquote  As Boolean
    Dim squote  As Boolean
    Dim char    As String
    
    Call skipChar(str, index)
    Do While index > 0 And index <= Len(str)
        char = Mid(str, index, 1)
        Select Case (char)
        Case """"
            dquote = Not dquote
            index = index + 1
            If Not dquote Then
                Call skipChar(str, index)
                If Mid(str, index, 1) <> ":" Then
                    Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                End If
            End If
        Case "'"
            squote = Not squote
            index = index + 1
            If Not squote Then
                Call skipChar(str, index)
                If Mid(str, index, 1) <> ":" Then
                    Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                End If
            End If
        Case ":"
            If Not dquote And Not squote Then
                index = index + 1
                Exit Do
            End If
        Case Else
            If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", char) Then
            Else
                parseKey = parseKey & char
            End If
            index = index + 1
        End Select
    Loop
 
End Function
 
'
'   skip special character
'
Private Sub skipChar(ByRef str As String, ByRef index As Long)
 
    While index > 0 And index <= Len(str) And InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Mid(str, index, 1))
        index = index + 1
    Wend
 
End Sub
 
Public Function toString(ByRef obj As Variant) As String
 
    Select Case VarType(obj)
        Case vbNull
            toString = "null"
        Case vbDate
            toString = """" & CStr(obj) & """"
        Case vbString
            toString = """" & encode(obj) & """"
        Case vbObject
            Dim bFI, i
            bFI = True
            If TypeName(obj) = "Dictionary" Then
                toString = toString & "{"
                Dim keys
                keys = obj.keys
                For i = 0 To obj.Count - 1
                    If bFI Then bFI = False Else toString = toString & ","
                    Dim key
                    key = keys(i)
                    toString = toString & """" & key & """:" & toString(obj(key))
                Next i
                toString = toString & "}"
            ElseIf TypeName(obj) = "Collection" Then
                toString = toString & "["
                Dim value
                For Each value In obj
                    If bFI Then bFI = False Else toString = toString & ","
                    toString = toString & toString(value)
                Next value
                toString = toString & "]"
            End If
        Case vbBoolean
            If obj Then toString = "true" Else toString = "false"
        Case vbVariant, vbArray, vbArray + vbVariant
            Dim sEB
            Dim NoDims As Long
            toString = multiArray(obj)
        Case Else
            toString = Replace(obj, ",", ".")
    End Select
 
End Function
 
Private Function encode(str) As String
    
    Dim i, j, aL1, aL2, c, p
 
    aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
    aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)
    For i = 1 To Len(str)
        p = True
        c = Mid(str, i, 1)
        For j = 0 To 7
            If c = Chr(aL1(j)) Then
                encode = encode & "\" & Chr(aL2(j))
                p = False
                Exit For
            End If
        Next
 
        If p Then
            Dim a
            a = AscW(c)
            If a > 31 And a < 127 Then
                encode = encode & c
            ElseIf a > -1 Or a < 65535 Then
                encode = encode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
            End If
        End If
    Next
End Function
 
Private Function multiArray(aBD)  ' Array BoDy, Integer BaseCount, String PoSition
    Dim NoDimensions
    Dim i1 As Long, i2 As Long
    Dim DimList(1 To 10) As Long
    
    NoDimensions = HowManyDimensions(aBD)
    Select Case NoDimensions
        Case 1
            multiArray = multiArray & "["
            For i1 = LBound(aBD, 1) To UBound(aBD, 1)
                multiArray = multiArray & toString(aBD(i1))
                If i1 < UBound(aBD, 1) Then multiArray = multiArray & ","
            Next i1
            multiArray = multiArray & "]"
        Case 2
            multiArray = multiArray & "["
            For i1 = LBound(aBD, 1) To UBound(aBD, 1)
                multiArray = multiArray & "["
                For i2 = LBound(aBD, 2) To UBound(aBD, 2)
                    multiArray = multiArray & toString(aBD(i1, i2))
                    If i2 < UBound(aBD, 2) Then multiArray = multiArray & ","
                Next i2
                multiArray = multiArray & "]"
                If i1 < UBound(aBD, 1) Then multiArray = multiArray & ","
            Next i1
            multiArray = multiArray & "]"
        Case Else
            'Not much point in doing anything here. The error would just leave it blank.
    End Select
End Function
 
Private Function HowManyDimensions(AnArray) As Long
    'find number of dimensions
    On Error GoTo DimensionOverflow
    Dim ErrorCheck As Long, DimensionNumber As Long
    For DimensionNumber = 1 To 60001
        ErrorCheck = LBound(AnArray, DimensionNumber)
    Next DimensionNumber
 
DimensionOverflow:
    HowManyDimensions = DimensionNumber - 1
End Function
 
Поиск по сайту