Solved

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

Posted on 2009-05-14
7
3,247 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
Does Powershell have you tied up in knots?

Managing Active Directory does not always have to be complicated.  If you are spending more time trying instead of doing, then it's time to look at something else. For nearly 20 years, AD admins around the world have used one tool for day-to-day AD management: Hyena. Discover why

 
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

Are your AD admin tools letting you down?

Managing Active Directory can get complicated.  Often, the native tools for managing AD are just not up to the task.  The largest Active Directory installations in the world have relied on one tool to manage their day-to-day administration tasks: Hyena. Start your trial today.

Question has a verified solution.

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

Suggested Solutions

Shadow IT is coming out of the shadows as more businesses are choosing cloud-based applications. It is now a multi-cloud world for most organizations. Simultaneously, most businesses have yet to consolidate with one cloud provider or define an offic…
In this article, I am going to show you how to simulate a multi-site Lab environment on a single Hyper-V host. I use this method successfully in my own lab to simulate three fully routed global AD Sites on a Windows 10 Hyper-V host.
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…
This tutorial will walk an individual through the process of configuring their Windows Server 2012 domain controller to synchronize its time with a trusted, external resource. Use Google, Bing, or other preferred search engine to locate trusted NTP …

943 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

Need Help in Real-Time?

Connect with top rated Experts

4 Experts available now in Live!

Get 1:1 Help Now