Question

我在excel文件中有一个全名用户列表。我希望通过从AD获取它来自动获取他们的部门的全名。

我的工作表Tabelle1有一个700多个用户的列表。在这种情况下，我需要自动完成以节省时间。

基本上，我想根据他们的全名查看AD。如果他们的全名在AD用户中匹配，那么在第7列中，它将放置部门。

我找到了一个代码，但我不确定如何继续：

Sub LoadUserInfo()
Dim x, objConnection, objCommand, objRecordSet, oUser, skip, disa
Dim sht As Worksheet
Dim Tabelle1 As Worksheet

' get domain
Dim oRoot
Set oRoot = GetObject("LDAP://rootDSE")
Dim sDomain
sDomain = oRoot.Get("defaultNamingContext")
Dim strLDAP
strLDAP = "LDAP://" & sDomain

Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 100
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

objCommand.CommandText = "SELECT adsPath FROM '" & strLDAP & "' WHERE objectCategory='person'AND objectClass='user'"
Set objRecordSet = objCommand.Execute

x = 2
Set sht = ThisWorkbook.Worksheets("Tabelle1")
With sht

    Do Until objRecordSet.EOF
        Set oUser = GetObject(objRecordSet.Fields("aDSPath"))
        skip = oUser.sAMAccountName
        disa = oUser.AccountDisabled

        If skip = .Cells(x, 5).Value Then

        .Cells(x, 7) = oUser.Department

            DoEvents
            objRecordSet.MoveNext



Else

            DoEvents

            x = x + 1
            objRecordSet.MoveNext
        End If

    Loop

End With


End Sub

Answer 1

您可以在查询中使用过滤器来获取匹配用户名的记录。

Sub test()
    MsgBox GetDepartment("Stark", "Tony")
End Sub

Function GetDepartment(strLastName As String, strFirstName As String) As String

    Dim objRoot             As Object
    Dim strDomain           As String
    Dim objConn             As Object
    Dim objComm             As Object
    Dim objRecordset        As Object

    Dim sFilter             As String
    Dim sAttribs            As String
    Dim sDepth              As String
    Dim sBase               As String
    Dim sQuery              As String


    Set objRoot = GetObject("LDAP://RootDSE")
    strDomain = objRoot.Get("DefaultNamingContext")
    Set objConn = CreateObject("ADODB.Connection")
    Set objComm = CreateObject("ADODB.Command")

    strLastName = Replace(strLastName, Space(1), "")
    strFirstName = Replace(strFirstName, Space(1), "")
    sFilter = "(&(objectClass=person)(objectCategory=user)(givenName=" & strFirstName & ")" & "(sn=" & strLastName & "*)" & ")"

    sAttribs = "department,sAMAccountName,givenName,sn"
    sDepth = "SubTree"
    sBase = "<LDAP://" & strDomain & ">"
    sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth

    objConn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
    Set objComm.ActiveConnection = objConn
    objComm.Properties("Page Size") = 40000
    objComm.CommandText = sQuery
    Set objRecordset = objComm.Execute

    Do Until objRecordset.EOF
       GetDepartment = objRecordset("department")
       Exit Function
       objRecordset.MoveNext
    Loop


End Function

根据Active Directory中的Fullname获取用户部门

1 个答案: