jamiepryer
asked on
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...
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
ASKER
thanks, any suggestions how to do that please?
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Fantastic, thanks so much for this - really helped me out!!
ASKER
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
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
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 ...