如何显示一系列单元格中的活动目录的结果

Posted 2021-04-16

我正在使用一个宏，使用部门号从活动目录中提取员工姓名。我需要能够显示每个发现在细胞范围内的员工，最好是Range("A1:A10")。我目前的宏将所有结果列入Range("B3")。任何帮助都将不胜感激。我分两部分分解了我的代码。员工点击用户表单中的按钮时会调用第1部分，第二部分是连接到活动目录的函数：

Sub链接到用户窗体上的命令按钮

Sub opsldap()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
struser = opslogin.TextBox1
struserdn = Get_LDAP_User_Properties("user", "department", struser, "displayName")
    If Len(struserdn) <> 0 Then
        ws.Range("B3").Value = struserdn
        MsgBox "Welcome to Op's Vision " & struserdn
    Else
        MsgBox "Cant Find"
    End If
End Sub

用于从Active Directory获取结果的函数

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
    On Error GoTo EarlyExit

    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.
        Set adoRecordset = adoCommand.Execute
    ' Enumerate the resulting recordset.
        strReturnVal = ""
    Do Until adoRecordset.EOF
        ' Retrieve values and display.
        For intCount = LBound(arrProperties) To UBound(arrProperties)
            If strReturnVal = "" Then
                strReturnVal = adoRecordset.Fields(intCount).Value
            Else
                strReturnVal = strReturnVal & vbCrLf & adoRecordset.Fields(intCount).Value
            End If
        Next
        ' Move to the next record in the recordset.
        adoRecordset.MoveNext
    Loop

    ' Clean up.
    adoRecordset.Close
    ADOConnection.Close
    Get_LDAP_User_Properties = strReturnVal
EarlyExit:
    On Error GoTo 0
End Function

答案

这是我正在使用的拆分数组：

Sub opsldap()
    Dim textstring As String, Warray() As String, counter As Integer, strg As String
    struser = opslogin.TextBox1
    struserdn = Get_LDAP_User_Properties("user", "department", struser, "displayName")

If Len(struserdn) <> 0 Then
    textstring = struserdn
    Warray() = split(textstring, vbNewLine)

    For counter = LBound(Warray) To UBound(Warray)

    strg = Warray(counter)
    Cells(counter + 3, 1).Value = Trim(strg)

Next counter

Else
    MsgBox "I couldnt locate that cost center"

End If
End Sub