Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 3535
  • Last Modified:

VB Script - AD LDAP query only returning 1500 members of an AD Group

Hi,
i have a script to select a group in excel and then display all the members of that group (ID and Name), however, this only ever returns 1500 entries!
I need this to return all values, even if more then 1500, however i have no idea how!
please help...
Public DomainArray
Option Base 1
 
Sub ShowGroupMembers2()
Dim arrNames()
Dim Result4 As String
Dim objConnection As New ADODB.Connection
Dim objCommand As New ADODB.Command
Dim objRecordset As ADODB.Recordset
 
On Error Resume Next
 
YesNo = MsgBox("CAUTION: This could take a while to run if you select an OU with a large number of users/groups!" & vbCrLf _
            & vbCrLf & _
            "Are you SURE you want to do this?", vbYesNo + vbQuestion, "Warning...")
    Select Case YesNo
        Case vbYes
            
        Case vbNo
            Exit Sub
    End Select
 
'shows the memebers of a group
 
Range("A1").Select
 
ActiveSheet.Select
 
Set rng = Application.InputBox(prompt:="Please select the groups you want to check", Title:="Selection Required...", Type:=8)
    If rng Is Nothing Then
        MsgBox "You didnt select any users!", vbExclamation, "Operation Cancelled..."
        Sheet1.Select
        Range("A1").Select
        End
    Else
        rng.Select
        ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:=rng
    End If
 
Set rWhole = Selection
 
I = 1
X = 1
 
'Set up the criteris for the LDAP searches
Const ADS_SCOPE_SUBTREE = 2
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Size Limit") = 100000
    objCommand.Properties("Timeout") = 30
    objCommand.Properties("Cache Results") = False
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
Set oRoot = GetObject("LDAP://RootDSE")
   strDomain = oRoot.Get("DefaultNamingContext")
 
For Each rCell In rWhole
    rCell.Select
    rCell.Font.Bold = True
    If rCell.Value = "" Then
        Exit For
    End If
    
    a = rCell.Address
 
    objCommand.CommandText = _
    "SELECT distinguishedName FROM 'LDAP://" & strDomain & "' WHERE objectCategory='group' " & _
        "AND cn='" & rCell & "'"
    
    Set objRecordset = objCommand.Execute
    
    objRecordset.MoveFirst
        Do Until objRecordset.EOF
            result = (objRecordset.Fields("distinguishedName").Value)
            objRecordset.MoveNext
        Loop
 
    Result4 = Right(result, (Len(result)) - (InStr(1, result, ",")))
    
    Set objGroup = GetObject("LDAP://Cn=" & rCell & ", " & Result4 & "")
        
    intRow = 1
    intSize = 1
 
    For Each strUser In objGroup.member
        Set objUser = GetObject("LDAP://" & strUser)
        ReDim Preserve arrNames(intSize)
        arrNames(intSize) = objUser.cn & ": " & objUser.DisplayName
        intSize = intSize + 1
    Next
    
    If UBound(arrNames) = 0 Then
        ActiveSheet.Range(a).Offset(intRow, 0) = "No Group Members"
    Else
    
    For Each strName In arrNames
        ActiveSheet.Range(a).Offset(intRow, 0) = strName
        intRow = intRow + 1
    Next
    End If
    ReDim arrNames(0)
    objGroup = ""
Next
 
Cells.EntireColumn.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    
Rows("2:2").Select
        ActiveWindow.FreezePanes = True
        
Range("A1").Select
 
End Sub

Open in new window

0
jamiepryer
Asked:
jamiepryer
  • 3
  • 3
1 Solution
 
Guy Hengel [angelIII / a3]Billing EngineerCommented:
from what I know, the LDAP queries indeed are limiting the query results.
so, you have to split the query into several runs to get all the items.

for example, get all items with distinguishedName like 'A%', tjhe B then C .etc ...
0
 
jamiepryerAuthor Commented:
thanks, any suggestions how to do that please?
0
 
Chris DentPowerShell DeveloperCommented:

You wouldn't be able to do distinguishedName LIKE, you can't use Wildcards for that particular field.

Anyway, this is a limitation in ADSI. You cannot return more than 1500 entries from a single multi-valued attribute (such as member).

You should be able to perform a search for the group members and have them all return. Hopefully it works as below :)

Chris
Function GetMembers(strGroupDN)
  ' Returns an array containing the members of the specified group.
 
  Dim strLdapFilter : strLdapFilter = "(memberOf=" & strGroupDN & ")"
 
  Dim objConnection : Set objConnection = CreateObject("ADODB.Connection")
  objConnection.Provider = "ADsDSOObject"
  objConnection.Open "Active Directory Provider"
 
  Dim objCommand : Set objCommand = CreateObject("ADODB.Command")
  objCommand.ActiveConnection = objConnection
  objCommand.Properties("Page Size") = 1000
 
  Dim objRootDSE : Set objRootDSE = GetObject("LDAP://RootDSE")
  objCommand.CommandText = "<LDAP://" & objRootDSE.Get("defaultNamingContext") & ">;" & _
    strLdapFilter & ";name,displayName,distinguishedName;subtree"
  
  Dim objRecordSet : Set objRecordSet = objCommand.Execute
 
  Dim arrResults() : Dim i : i = 0
  Do Until objRecordSet.EOF
    ReDim Preserve arrResults(i)
    Dim strDisplayName
    If Not IsNull(objRecordSet.Fields("displayName")) Then
      strDisplayName = objRecordSet.Fields("displayName").Value
    Else
      strDisplayName = ""
    End If
 
    arrResults(i) = objRecordSet.Fields("name").Value & ": " & strDisplayName
 
    i = i + 1
    objRecordSet.MoveNext
  Loop
 
  GetMembers = arrResults
End Function
 
 
Public DomainArray
Option Base 1
 
Sub ShowGroupMembers2()
Dim arrNames()
Dim Result4 As String
Dim objConnection As New ADODB.Connection
Dim objCommand As New ADODB.Command
Dim objRecordset As ADODB.Recordset
 
On Error Resume Next
 
YesNo = MsgBox("CAUTION: This could take a while to run if you select an OU with a large number of users/groups!" & vbCrLf _
            & vbCrLf & _
            "Are you SURE you want to do this?", vbYesNo + vbQuestion, "Warning...")
    Select Case YesNo
        Case vbYes
            
        Case vbNo
            Exit Sub
    End Select
 
'shows the memebers of a group
 
Range("A1").Select
 
ActiveSheet.Select
 
Set rng = Application.InputBox(prompt:="Please select the groups you want to check", Title:="Selection Required...", Type:=8)
    If rng Is Nothing Then
        MsgBox "You didnt select any users!", vbExclamation, "Operation Cancelled..."
        Sheet1.Select
        Range("A1").Select
        End
    Else
        rng.Select
        ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:=rng
    End If
 
Set rWhole = Selection
 
I = 1
X = 1
 
'Set up the criteris for the LDAP searches
Const ADS_SCOPE_SUBTREE = 2
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Size Limit") = 100000
    objCommand.Properties("Timeout") = 30
    objCommand.Properties("Cache Results") = False
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
Set oRoot = GetObject("LDAP://RootDSE")
   strDomain = oRoot.Get("DefaultNamingContext")
 
For Each rCell In rWhole
    rCell.Select
    rCell.Font.Bold = True
    If rCell.Value = "" Then
        Exit For
    End If
    
    a = rCell.Address
 
    objCommand.CommandText = _
    "SELECT distinguishedName FROM 'LDAP://" & strDomain & "' WHERE objectCategory='group' " & _
        "AND cn='" & rCell & "'"
    
    Set objRecordset = objCommand.Execute
    
    objRecordset.MoveFirst
        Do Until objRecordset.EOF
            result = (objRecordset.Fields("distinguishedName").Value)
            objRecordset.MoveNext
        Loop
 
    Result4 = Right(result, (Len(result)) - (InStr(1, result, ",")))
    
    Set objGroup = GetObject("LDAP://Cn=" & rCell & ", " & Result4 & "")
        
    intRow = 1
    intSize = 1
 
    arrNames = GetMembers("LDAP://CN=" & rCell & "," & Result4)
 
    'For Each strUser In objGroup.member
    '    Set objUser = GetObject("LDAP://" & strUser)
    '    ReDim Preserve arrNames(intSize)
    '    arrNames(intSize) = objUser.cn & ": " & objUser.DisplayName
    '    intSize = intSize + 1
    'Next
    
    If UBound(arrNames) = 0 Then
        ActiveSheet.Range(a).Offset(intRow, 0) = "No Group Members"
    Else
    
    For Each strName In arrNames
        ActiveSheet.Range(a).Offset(intRow, 0) = strName
        intRow = intRow + 1
    Next
    End If
    ReDim arrNames(0)
    objGroup = ""
Next
 
Cells.EntireColumn.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    
Rows("2:2").Select
        ActiveWindow.FreezePanes = True
        
Range("A1").Select
 
End Sub

Open in new window

0
Easily Design & Build Your Next Website

Squarespace’s all-in-one platform gives you everything you need to express yourself creatively online, whether it is with a domain, website, or online store. Get started with your free trial today, and when ready, take 10% off your first purchase with offer code 'EXPERTS'.

 
Chris DentPowerShell DeveloperCommented:

Except it won't because included an error. Fixed here.

Chris
Function GetMembers(strGroupDN)
  ' Returns an array containing the members of the specified group.
 
  Dim strLdapFilter : strLdapFilter = "(memberOf=" & strGroupDN & ")"
 
  Dim objConnection : Set objConnection = CreateObject("ADODB.Connection")
  objConnection.Provider = "ADsDSOObject"
  objConnection.Open "Active Directory Provider"
 
  Dim objCommand : Set objCommand = CreateObject("ADODB.Command")
  objCommand.ActiveConnection = objConnection
  objCommand.Properties("Page Size") = 1000
 
  Dim objRootDSE : Set objRootDSE = GetObject("LDAP://RootDSE")
  objCommand.CommandText = "<LDAP://" & objRootDSE.Get("defaultNamingContext") & ">;" & _
    strLdapFilter & ";name,displayName,distinguishedName;subtree"
  
  Dim objRecordSet : Set objRecordSet = objCommand.Execute
 
  Dim arrResults() : Dim i : i = 0
  Do Until objRecordSet.EOF
    ReDim Preserve arrResults(i)
    Dim strDisplayName
    If Not IsNull(objRecordSet.Fields("displayName")) Then
      strDisplayName = objRecordSet.Fields("displayName").Value
    Else
      strDisplayName = ""
    End If
 
    arrResults(i) = objRecordSet.Fields("name").Value & ": " & strDisplayName
 
    i = i + 1
    objRecordSet.MoveNext
  Loop
 
  GetMembers = arrResults
End Function
 
 
Public DomainArray
Option Base 1
 
Sub ShowGroupMembers2()
Dim arrNames()
Dim Result4 As String
Dim objConnection As New ADODB.Connection
Dim objCommand As New ADODB.Command
Dim objRecordset As ADODB.Recordset
 
On Error Resume Next
 
YesNo = MsgBox("CAUTION: This could take a while to run if you select an OU with a large number of users/groups!" & vbCrLf _
            & vbCrLf & _
            "Are you SURE you want to do this?", vbYesNo + vbQuestion, "Warning...")
    Select Case YesNo
        Case vbYes
            
        Case vbNo
            Exit Sub
    End Select
 
'shows the memebers of a group
 
Range("A1").Select
 
ActiveSheet.Select
 
Set rng = Application.InputBox(prompt:="Please select the groups you want to check", Title:="Selection Required...", Type:=8)
    If rng Is Nothing Then
        MsgBox "You didnt select any users!", vbExclamation, "Operation Cancelled..."
        Sheet1.Select
        Range("A1").Select
        End
    Else
        rng.Select
        ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:=rng
    End If
 
Set rWhole = Selection
 
I = 1
X = 1
 
'Set up the criteris for the LDAP searches
Const ADS_SCOPE_SUBTREE = 2
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Size Limit") = 100000
    objCommand.Properties("Timeout") = 30
    objCommand.Properties("Cache Results") = False
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
Set oRoot = GetObject("LDAP://RootDSE")
   strDomain = oRoot.Get("DefaultNamingContext")
 
For Each rCell In rWhole
    rCell.Select
    rCell.Font.Bold = True
    If rCell.Value = "" Then
        Exit For
    End If
    
    a = rCell.Address
 
    objCommand.CommandText = _
    "SELECT distinguishedName FROM 'LDAP://" & strDomain & "' WHERE objectCategory='group' " & _
        "AND cn='" & rCell & "'"
    
    Set objRecordset = objCommand.Execute
    
    objRecordset.MoveFirst
        Do Until objRecordset.EOF
            result = (objRecordset.Fields("distinguishedName").Value)
            objRecordset.MoveNext
        Loop
 
    Result4 = Right(result, (Len(result)) - (InStr(1, result, ",")))
    
    Set objGroup = GetObject("LDAP://Cn=" & rCell & ", " & Result4 & "")
        
    intRow = 1
    intSize = 1
 
    arrNames = GetMembers("CN=" & rCell & "," & Result4)
 
    'For Each strUser In objGroup.member
    '    Set objUser = GetObject("LDAP://" & strUser)
    '    ReDim Preserve arrNames(intSize)
    '    arrNames(intSize) = objUser.cn & ": " & objUser.DisplayName
    '    intSize = intSize + 1
    'Next
    
    If UBound(arrNames) = 0 Then
        ActiveSheet.Range(a).Offset(intRow, 0) = "No Group Members"
    Else
    
    For Each strName In arrNames
        ActiveSheet.Range(a).Offset(intRow, 0) = strName
        intRow = intRow + 1
    Next
    End If
    ReDim arrNames(0)
    objGroup = ""
Next
 
Cells.EntireColumn.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    
Rows("2:2").Select
        ActiveWindow.FreezePanes = True
        
Range("A1").Select
 
End Sub

Open in new window

0
 
jamiepryerAuthor Commented:
Fantastic, thanks so much for this - really helped me out!!
0
 
jamiepryerAuthor Commented:
final code, as a couple of things had to be moved and i had to = 1


Public DomainArray
Option Base 1
 
Function GetMembers(strGroupDN)
  ' Returns an array containing the members of the specified group.
 
  Dim strLdapFilter: strLdapFilter = "(memberOf=" & strGroupDN & ")"
 
  Dim objConnection: Set objConnection = CreateObject("ADODB.Connection")
  objConnection.Provider = "ADsDSOObject"
  objConnection.Open "Active Directory Provider"
 
  Dim objCommand: Set objCommand = CreateObject("ADODB.Command")
  objCommand.ActiveConnection = objConnection
  objCommand.Properties("Page Size") = 1000
 
  Dim objRootDSE: Set objRootDSE = GetObject("LDAP://RootDSE")
  objCommand.CommandText = "<LDAP://" & objRootDSE.Get("defaultNamingContext") & ">;" & _
    strLdapFilter & ";name,displayName,distinguishedName;subtree"
  
  Dim objRecordset: Set objRecordset = objCommand.Execute
 
  Dim arrResults(): Dim i: i = 1
  Do Until objRecordset.EOF
    ReDim Preserve arrResults(i)
    Dim strDisplayName
    If Not IsNull(objRecordset.Fields("displayName")) Then
      strDisplayName = objRecordset.Fields("displayName").Value
    Else
      strDisplayName = ""
    End If
 
    arrResults(i) = objRecordset.Fields("name").Value & ": " & strDisplayName
 
    i = i + 1
    objRecordset.MoveNext
  Loop
 
  GetMembers = arrResults
End Function
 
 
 
 
Sub ShowGroupMembers2()
Dim arrNames()
Dim Result4 As String
Dim objConnection As New ADODB.Connection
Dim objCommand As New ADODB.Command
Dim objRecordset As ADODB.Recordset
 
YesNo = MsgBox("CAUTION: This could take a while to run if you select an OU with a large number of users/groups!" & vbCrLf _
            & vbCrLf & _
            "Are you SURE you want to do this?", vbYesNo + vbQuestion, "Warning...")
    Select Case YesNo
        Case vbYes
            
        Case vbNo
            Exit Sub
    End Select
 
'shows the memebers of a group
 
Range("A1").Select
 
ActiveSheet.Select
 
Set rng = Application.InputBox(prompt:="Please select the groups you want to check", Title:="Selection Required...", Type:=8)
    If rng Is Nothing Then
        MsgBox "You didnt select any users!", vbExclamation, "Operation Cancelled..."
        Sheet1.Select
        Range("A1").Select
        End
    Else
        rng.Select
        ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:=rng
    End If
 
Set rWhole = Selection
 
i = 1
X = 1
 
'Set up the criteris for the LDAP searches
Const ADS_SCOPE_SUBTREE = 2
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Size Limit") = 100000
    objCommand.Properties("Timeout") = 30
    objCommand.Properties("Cache Results") = False
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
Set oRoot = GetObject("LDAP://RootDSE")
   strDomain = oRoot.Get("DefaultNamingContext")
 
For Each rCell In rWhole
    rCell.Select
    rCell.Font.Bold = True
    If rCell.Value = "" Then
        Exit For
    End If
    
    a = rCell.Address
 
    objCommand.CommandText = _
    "SELECT distinguishedName FROM 'LDAP://" & strDomain & "' WHERE objectCategory='group' " & _
        "AND cn='" & rCell & "'"
    
    Set objRecordset = objCommand.Execute
    
    objRecordset.MoveFirst
        Do Until objRecordset.EOF
            result = (objRecordset.Fields("distinguishedName").Value)
            objRecordset.MoveNext
        Loop
 
    Result4 = Right(result, (Len(result)) - (InStr(1, result, ",")))
    
    Set objGroup = GetObject("LDAP://Cn=" & rCell & ", " & Result4 & "")
        
    intRow = 1
    intSize = 1
 
    arrNames = GetMembers("CN=" & rCell & "," & Result4)
 
    'For Each strUser In objGroup.member
    '    Set objUser = GetObject("LDAP://" & strUser)
    '    ReDim Preserve arrNames(intSize)
    '    arrNames(intSize) = objUser.cn & ": " & objUser.DisplayName
    '    intSize = intSize + 1
    'Next
    
    If UBound(arrNames) = 0 Then
        ActiveSheet.Range(a).Offset(intRow, 0) = "No Group Members"
    Else
    
    For Each strName In arrNames
        ActiveSheet.Range(a).Offset(intRow, 0) = strName
        intRow = intRow + 1
    Next
    End If
    ReDim arrNames(0)
    objGroup = ""
Next
 
Cells.EntireColumn.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    
Rows("2:2").Select
        ActiveWindow.FreezePanes = True
        
Range("A1").Select
 
End Sub

Open in new window

0
 
Chris DentPowerShell DeveloperCommented:

Ahh I see, you had this:

If UBound(arrNames) = 0 Then

Didn't see that.

Numbering for arrays starts at 0, so 0 is a valid element. It's no bother if you're just using that to test for a blank, however you may consider Re-Dimensioning the array to 0 immediately after it's declared as a dynamic array. Otherwise you can end up with an uninitialised array (as size is only increased if the query returns results), UBound would throw and error in that instance.

e.g.

Dim arrResults(): Dim i : i = 1 : ReDim arrResults(0)

Chris
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now