Solved

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

Posted on 2009-05-14
7
3,222 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
 
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

Join & Write a Comment

Entity Framework is a powerful tool to help you interact with the DataBase but still doesn't help much when we have a Stored Procedure that returns more than one resultset. The solution takes some of out-of-the-box thinking; read on!
CCModeler offers a way to enter basic information like entities, attributes and relationships and export them as yEd or erviz diagram. It also can import existing Access or SQL Server tables with relationships.
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ā€¦
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filledā€¦

758 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

18 Experts available now in Live!

Get 1:1 Help Now