Solved

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

Posted on 2009-05-14
7
3,292 Views
Last Modified: 2013-12-24
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
Comment
Question by:jamiepryer
  • 3
  • 3
7 Comments
 
LVL 142

Expert Comment

by:Guy Hengel [angelIII / a3]
ID: 24383982
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
 

Author Comment

by:jamiepryer
ID: 24384257
thanks, any suggestions how to do that please?
0
 
LVL 70

Expert Comment

by:Chris Dent
ID: 24384300

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
Netscaler Common Configuration How To guides

If you use NetScaler you will want to see these guides. The NetScaler How To Guides show administrators how to get NetScaler up and configured by providing instructions for common scenarios and some not so common ones.

 
LVL 70

Accepted Solution

by:
Chris Dent earned 500 total points
ID: 24384308

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
 

Author Closing Comment

by:jamiepryer
ID: 31581416
Fantastic, thanks so much for this - really helped me out!!
0
 

Author Comment

by:jamiepryer
ID: 24393275
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
 
LVL 70

Expert Comment

by:Chris Dent
ID: 24393315

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

Featured Post

PRTG Network Monitor: Intuitive Network Monitoring

Network Monitoring is essential to ensure that computer systems and network devices are running. Use PRTG to monitor LANs, servers, websites, applications and devices, bandwidth, virtual environments, remote systems, IoT, and many more. PRTG is easy to set up & use.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Disabling the Directory Sync Service Account in Office 365 will stop directory synchronization from working.
This article outlines the process to identify and resolve account lockout in an Active Directory environment.
This tutorial will walk an individual through the process of transferring the five major, necessary Active Directory Roles, commonly referred to as the FSMO roles from a Windows Server 2008 domain controller to a Windows Server 2012 domain controlle…
Microsoft Active Directory, the widely used IT infrastructure, is known for its high risk of credential theft. The best way to test your Active Directory’s vulnerabilities to pass-the-ticket, pass-the-hash, privilege escalation, and malware attacks …

810 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question