Контроллер домена и пользователь на основе электронной почты VBA

Question

Я пытаюсь разрешить имя контроллера домена и имя пользователя (dc \ user), используя адрес электронной почты.

У меня есть код ниже (заимствовано), но он разрешает только имя пользователя для домена по умолчанию. Любые предложения высоко ценится.

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)

    If InStr(strObjectToGet, "\") > 0 Then
        arrGroupBits = Split(strObjectToGet, "\")
        strDC = arrGroupBits(0)
        strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
        strObjectToGet = arrGroupBits(1)
    Else
        ' Otherwise we just connect to the default domain
        Set objRootDSE = GetObject("LDAP://RootDSE")
        strDNSDomain = objRootDSE.Get("defaultNamingContext")
    End If

    strBase = "<LDAP://" & strDNSDomain & ">"
    ' Setup ADO objects.
    Set adoCommand = CreateObject("ADODB.Command")
    Set ADOConnection = CreateObject("ADODB.Connection")
    ADOConnection.Provider = "ADsDSOObject"
    ADOConnection.Open "Active Directory Provider"
    adoCommand.ActiveConnection = ADOConnection


    ' Filter on user objects.
    'strFilter = "(&(objectCategory=person)(objectClass=user))"
    strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"

    ' Comma delimited list of attribute values to retrieve.
    strAttributes = strCommaDelimProps
    arrProperties = Split(strCommaDelimProps, ",")

    ' Construct the LDAP syntax query.
    strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
    adoCommand.CommandText = strQuery
    ' Define the maximum records to return
    adoCommand.Properties("Page Size") = 100
    adoCommand.Properties("Timeout") = 30
    adoCommand.Properties("Cache Results") = False

    ' Run the query.


End Function

Заранее спасибо Михал

Answer 1

Это должен быть код, необходимый для получения того, что вы хотите.

Он берет адрес электронной почты и возвращает атрибуты, перечисленные в strAttributes запрашиваемого пользователя.

Пример:

Вход: LdapUserByMailAddress("ad.user@ad.example.com")
Выход: sn: Doe; givenName: John; mail: ad.user@ad.example.com;
Значение strBaseDn: <LDAP://dc=ad,dc=example,dc=com>

Public Function LdapUserByMailAddress(strMailAddress As String) As String
    Dim arrMailParts() As String
    Dim strUsername As String
    Dim strDomain As String
    Dim strBaseDn As String
    Dim strFilter As String
    Dim strQuery As String
    Dim strAttributes As String
    Dim arrAttributes() As String
    Dim i As Integer
    Dim j As Integer

    strAttributes = "mail,sn,givenName"
    arrAttributes = Split(strAttributes, ",")

    arrMailParts = Split(strMailAddress, "@")

    If 1 <> UBound(arrMailParts) Then
        LdapUserByMailAddress = "Not a valid email address"
        Exit Function
    End If

    strUsername = arrMailParts(0)
    strDomain = arrMailParts(1)

    strBaseDn = "<LDAP://dc=" & Replace(strDomain, ".", ",dc=") & ">"

    strFilter = "(sAMAccountName=" & strUsername & ")"

    ' Construct the LDAP syntax query.
    strQuery = strBaseDn & ";" & strFilter & ";" & strAttributes & ";subtree"

    Set adoCommand = CreateObject("ADODB.Command")
    Set ADOConnection = CreateObject("ADODB.Connection")
    ADOConnection.Provider = "ADsDSOObject"
    ADOConnection.Open "Active Directory Provider"
    adoCommand.ActiveConnection = ADOConnection
    adoCommand.CommandText = strQuery
    adoCommand.Properties("Page Size") = 100
    adoCommand.Properties("Timeout") = 30
    adoCommand.Properties("Cache Results") = False

    Set resultSet = adoCommand.Execute
    LdapUserByMailAddress = ""
    For i = 0 To resultSet.Fields.Count - 1
        LdapUserByMailAddress = LdapUserByMailAddress & resultSet.Fields(i).Name & ": "

        If resultSet.Fields(i).Type = adVariant And Not (IsNull(resultSet.Fields(i).Value)) Then
            ' For Multi Value attribute.
            LdapUserByMailAddress = LdapUserByMailAddress & "[MultiValue]"
            For j = LBound(resultSet.Fields(i).Value) To UBound(resultSet.Fields(i).Value)
                LdapUserByMailAddress = LdapUserByMailAddress & resultSet.Fields(i).Value(j) & " # "
            Next j
        Else
            ' For Single Value attribute.
             LdapUserByMailAddress = LdapUserByMailAddress & resultSet.Fields(i).Value
        End If

        LdapUserByMailAddress = LdapUserByMailAddress & ";"
    Next i

End Function

Answer 2

Пожалуйста, уточните данные адреса электронной почты и добавьте примеры параметров strObjectType, strSearchField, strObjectToGet and strCommaDelimProps при вызове функции Get_LDAP_User_Properties().

Каков ожидаемый результат?

Каков реальный результат ?

Моя интерпретация вашего вопроса: Вы ввели адрес электронной почты, подобный myuser@dc.example.com, и вы хотите получить следующий результат: dc.example.com\myuser

Это правильно?

В таком случае это может быть решением:

Public Function LdapUserByMailAddress(strMailAddress As String) As String
    Dim arrParts() As String

    arrParts = Split(strMailAddress, "@")

    If 1 <> UBound(arrParts) Then
        LdapUserByMailAddress = "Not a valid email address"
        Exit Function
    End If

    LdapUserByMailAddress = arrParts(1) & "\" & arrParts(0)

End Function

Если вы вызовете эту функцию в своем рабочем листе со следующим кодом: =LdapUserByMailAddress("user@dc.example.com")

, вы получите такой результат: dc.example.com\user