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

时间:2018-09-02 08:35:12

标签: excel excel-vba ldap

我正在使用一个宏,该宏使用部门号从活动目录中提取员工姓名。我需要能够显示在一个单元格区域(最好是Range("A1:A10"))中找到的每个员工。我当前的宏将所有结果列出到Range("B3")中。任何帮助,将不胜感激。我将代码分为两部分。当员工从用户窗体中单击按钮时,第一部分被调用,第二部分是连接到活动目录的函数:

子链接到用户表单上的命令按钮

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

1 个答案:

答案 0 :(得分:0)

这是我正在使用的分割数组:

ground.physicsBody = SKPhysicsBody(rectangleOfSize: CGSize(width: self.frame.size.width, height: groundTexture.size().height * 2.0))