Excel VBA - LDAP 管理限制的解决方法

Question

在用户窗体中，我有多个列表框。

1. Active Directory (AD) 中所有组的列表；
2. 从 ListBox1 中选定的组的列表；
3. 这些选定组的唯一成员列表（因此使用字典，因为某些用户可以是多个组的成员）；

我现在的情况是，第一个和第二个列表工作正常，但是当查询返回超过 1000 条记录时，我就达到了 LDAP 管理限制，这将返回运行时错误“错误 -2147016669”。正是这个问题，供参考。任何低于 1000 的值都会使代码运行顺利。

我正在进入不熟悉的领域，并且无法找到实现“页面大小”属性的正确方法，以便完整的用户列表将填充初始化的字典：

Private Sub Button1_Click()

Set rootDSE = GetObject("LDAP://rootDSE")
domainDN = rootDSE.Get("defaultNamingContext")
Set ado = CreateObject("ADODB.Connection")
ado.Provider = "ADSDSOObject"
ado.Open "ADSearch"

Set Dict_members = CreateObject("Scripting.Dictionary")
For n = 0 To ListBox2.ListCount - 1
    If Me.ListBox2.Selected(n) = True Then
        ldapFilter = "(sAMAccountName=" & Me.ListBox2.List(n) & ")"
        Set objectList = ado.Execute("<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,primaryGroupToken;subtree")
        groupDN = objectList.Fields("distinguishedName")
        groupRID = objectList.Fields("primaryGroupToken")
        ldapFilter = "(|(memberOf=" & groupDN & ")(primaryGroupID=" & groupRID & "))"
        Set objectList = ado.Execute("<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,samAccountName,displayname,userPrincipalName;subtree")
        While Not objectList.EOF
            On Error Resume Next
                If Not IsNull(objectList.Fields("userPrincipalName")) Then
                    Dict_members(objectList.Fields("userPrincipalName").Value) = 1
                End If
                'logonNameUPN = objectList.Fields("userPrincipalName")
            On Error GoTo 0
            objectList.MoveNext
        Wend
        objectList.Close
    End If
Next

ado.Close
Me.ListBox3.List = Dict_members.Keys
Me.Label6.Caption = Dict_members.Count

End Sub

我想这个想法是以 1000 个为批次进行“循环”。任何帮助都将不胜感激。

Answer 1

我现在可以使用了；当然我不知道到底为什么：

Private Sub Label5_Click()

Set rootDSE = GetObject("LDAP://rootDSE")
domainDN = rootDSE.Get("defaultNamingContext")
Set ado = CreateObject("ADODB.Connection")
ado.Open "Provider=ADsDSOObject;"
Set AdoCmd = CreateObject("ADODB.Command")
AdoCmd.ActiveConnection = ado
AdoCmd.Properties("Page Size") = 1000

Set Dict_members = CreateObject("Scripting.Dictionary")
For n = 0 To ListBox2.ListCount - 1
    If Me.ListBox2.Selected(n) = True Then
        ldapFilter = "(sAMAccountName=" & Me.ListBox2.List(n) & ")"
        AdoCmd.CommandText = "<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,primaryGroupToken;subtree"
        Set objectList = AdoCmd.Execute
        groupDN = objectList.Fields("distinguishedName")
        groupRID = objectList.Fields("primaryGroupToken")
        ldapFilter = "(|(memberOf=" & groupDN & ")(primaryGroupID=" & groupRID & "))"
        AdoCmd.CommandText = "<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,samAccountName,displayname,userPrincipalName;subtree"
        Set objectList = AdoCmd.Execute
        While Not objectList.EOF
            On Error Resume Next
                If Not IsNull(objectList.Fields("userPrincipalName")) Then
                    Dict_members(objectList.Fields("userPrincipalName").Value) = 1
                End If
            On Error GoTo 0
            objectList.MoveNext
        Wend
        objectList.Close
    End If
Next

ado.Close
Me.ListBox3.List = Dict_members.Keys
Me.Label6.Caption = Dict_members.Count

End Sub

所以与我最初使用的代码不同的是：

• ado.Open "Provider=ADsDSOObject;"代替ado.Open "ADSearch";
• 'ADODB.Command' 能够使用和设置属性。为了正确执行，我还必须初始化 AdoCmd.CommandText，然后执行。

由于某种原因更直接：

Set objectList = AdoCmd.Execute("<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,primaryGroupToken;subtree")

会产生错误。

这是一些试验和错误的结果，但它现在工作完美，并且如果需要的话将返回成千上万的用户。

Answer 2

您可能对这段代码工作得太辛苦了。如果是我，我会使用 Power Query 从 Active Directory 中提取我想要的所有列，然后只使用普通的 Excel 表和数据透视操作。

数据 > 获取数据 > 从其他来源 > 从 Active Directory