VBA to AD - error after 1000 users

July 25, 2016 at 18:16:49
Specs: Windows 7
I am currently working on a project to query AD , I have a script that do that, but the script is failing after 1000 users , while the users I am querying is around 150.000 users

here is my script


Sub UserSynchQuery(ByRef res As APIResult, ByRef oRespDS As APIDataSet, ByRef sLDAPServer As String, ByRef sLDAPPort As String, ByRef sLDAPBase As String, ByRef sUserName As String, ByRef sPassword As String, ByRef sSLPPrimary As String, ByRef sSLPSecondary As String, ByRef sExtension As String, ByRef sConfiggroup As String, ByRef sFilter As String )

Trace( "Called UserSynchQuery Entered" )

Dim oDSP As Object
Dim oDSRS As Object

On Error Resume Next
Set oDSP = CreateObject("ADODB.Connection")
oDSP.Provider = "ADSDSOObject"

oDSP.Open( "Ads Provider", sUserName, Demung( sPassword ))

If Err.Number <> 0 Then
Trace("ERROR: Failed to instantiate ADO Object. " & Err.Number & " " & Err.Description)
res.Code = "FAILED"
res.Reason = "Failed to instantiate ADO Object"
Exit Sub
End If

On Error Goto 0

Dim sRoot 'Holds the root of the LDAP object
sRoot = "LDAP://" & sLDAPServer & ":" & sLDAPPort & "/" & sLDAPBase

Dim sQuery As String
Dim sSelect As String

sSelect = ADS_COLUMN_DN & "," & ADS_COLUMN_USERNAME & "," & ADS_COLUMN_LASTNAME & "," & ADS_COLUMN_FIRSTNAME & "," & ADS_COLUMN_EMAIL & ","

...
...
oDSRS.MoveNext
Loop

the variable of LDAP SERVER, LDAP PORT, Username, Password and search base for both user and group is entered via application and it is working so far

error what I have is once it reaches 1000 users "The size limit for this request was exceeded."

If i removed this line oDSRS.MoveNext it will give "Overflow " error

I did some reading and this is the closest i come with
http://www.computing.net/answers/pr...

can you please help


See More: VBA to AD - error after 1000 users

Reply ↓  Report •


#1
July 25, 2016 at 18:17:39
I saw this link

http://www.computing.net/answers/pr...

and it is exactly what I am looking for, any help


Reply ↓  Report •

#2
July 25, 2016 at 22:14:57
oDSP.Open( "Ads Provider", sUserName, Demung( sPassword ))

Does DSP support a "close" method? maybe you need to do that between each cycle of username (ie: prior to "movenext"). I'm clueless about this, but I tend to think that most "opens" need a "close" counterpart, but not always if it's implicit. Anyway:
https://msdn.microsoft.com/en-us/li...
was my only source of (very brief) research, so...


Reply ↓  Report •

#3
July 25, 2016 at 23:42:52
Have a look at this thread and see if it helps: https://social.msdn.microsoft.com/F...

Reply ↓  Report •

Related Solutions

#4
July 26, 2016 at 05:56:27
hifzieboy: I saw this link ... and it is exactly what I am looking for, any help
If you found exactly what you're looking for, what more help could you need?

How To Ask Questions The Smart Way


Reply ↓  Report •

#5
July 26, 2016 at 09:52:09
the cycle is fine, I remove the on error resume next, it goes on

Reply ↓  Report •

#6
July 27, 2016 at 16:24:26
HI I saw that I need to add Command.Properties("Page Size") = 1000, but i am not sure on which part of the script I need to put it

Reply ↓  Report •

#7
July 27, 2016 at 16:40:39
Somewhere between the time you make the object, and the time you call Command.Execute.

How To Ask Questions The Smart Way


Reply ↓  Report •

#8
July 28, 2016 at 14:03:00
below is my script , can you tell me on which line

Sub UserSynchQuery(ByRef res As APIResult, ByRef oRespDS As APIDataSet, ByRef sLDAPServer As String, ByRef sLDAPPort As String, ByRef sLDAPBase As String, ByRef sUserName As String, ByRef sPassword As String, ByRef sSLPPrimary As String, ByRef sSLPSecondary As String, ByRef sExtension As String, ByRef sConfiggroup As String, ByRef sFilter As String )

Trace( "Called UserSynchQuery Entered" )

Dim oDSP As Object
Dim oDSRS As Object

On Error Resume Next
Set oDSP = CreateObject("ADODB.Connection")
oDSP.Provider = "ADSDSOObject"

oDSP.Open( "Ads Provider", sUserName, Demung( sPassword ))

If Err.Number <> 0 Then
Trace("ERROR: Failed to instantiate ADO Object. " & Err.Number & " " & Err.Description)
res.Code = "FAILED"
res.Reason = "Failed to instantiate ADO Object"
Exit Sub
End If

On Error Goto 0

Dim sRoot 'Holds the root of the LDAP object
sRoot = "LDAP://" & sLDAPServer & ":" & sLDAPPort & "/" & sLDAPBase

Dim sQuery As String
Dim sSelect As String

sSelect = ADS_COLUMN_DN & "," & ADS_COLUMN_USERNAME & "," & ADS_COLUMN_LASTNAME & "," & ADS_COLUMN_FIRSTNAME & "," & ADS_COLUMN_EMAIL & ","

If Len(sSLPPrimary) > 0 Then
sSelect = sSelect & sSLPPrimary & ","
End If
If Len(sSLPSecondary) > 0 Then
sSelect = sSelect & sSLPSecondary & ","
End If
If Len(sExtension) > 0 Then
sSelect = sSelect & sExtension & ","
End If
If Len(sConfiggroup) > 0 Then
sSelect = sSelect & sConfiggroup & ","
End If

sSelect = sSelect & ADS_COLUMN_MEMBEROF

sQuery = "SELECT " & sSelect & " FROM '" & sRoot & "' WHERE " & sFilter

Trace( "Query String: " & sQuery )

On Error Resume Next
Set oDSRS = oDSP.Execute(sQuery)

If Err.Number <> 0 Then
Trace("ERROR: Query Failed. " & Err.Number & " " & Err.Description)
res.Code = "FAILED"
res.Reason = "Query Failed"
Exit Sub
End If

On Error Goto 0

'// before you can fill in the dataset, you must initialize it with the
'// number of columns
oRespDS.Initialize(MSG_USER_QUERY_RESP_NUM_COLS)


Dim nRow
Dim sRSUserName
Dim sRSLastName
Dim sRSFirstName
Dim sRSEmail
Dim sRSDN
Dim sRSSLPPrimary
Dim sRSSLPSecondary
Dim sRSExtension
Dim sRSConfiggroup

nRow = 0

Do Until oDSRS.EOF

sRSUserName = oDSRS.Fields(ADS_COLUMN_USERNAME).Value
sRSLastName = oDSRS.Fields(ADS_COLUMN_LASTNAME).Value
sRSFirstName = oDSRS.Fields(ADS_COLUMN_FIRSTNAME).Value
sRSEmail = oDSRS.Fields(ADS_COLUMN_EMAIL).Value
sRSDN = oDSRS.Fields(ADS_COLUMN_DN).Value

Trace("----------- Found User -----------")
Trace("Username: " & sRSUserName)
Trace("Last Name: " & sRSLastName)
Trace("First Name: " & sRSFirstName)
Trace("Email: " & sRSEmail)
Trace("DN: " & sRSDN)
If Len(sSLPPrimary) > 0 Then
sRSSLPPrimary = oDSRS.Fields(sSLPPrimary).Value
Trace("sSLPPrimary: " & sRSSLPPrimary)
End If
If Len(sSLPSecondary) > 0 Then
sRSSLPSecondary = oDSRS.Fields(sSLPSecondary).Value
Trace("sSLPSecondary: " & sRSSLPSecondary)
End If
If Len(sExtension) > 0 Then
sRSExtension = oDSRS.Fields(sExtension).Value
Trace("sExtension: " & sRSExtension)
End If
If Len(sConfiggroup) > 0 Then
sRSConfiggroup = oDSRS.Fields(sConfiggroup).Value
Trace("sConfiggroup: " & sRSConfiggroup)
End If

If( IsNull( sRSUserNamme ) Or IsNull( sRSLastName ) Or IsNull( sRSFirstName ) Or IsNull( sRSDN ) ) Then
Trace( "Error: Ignoring user due to missing information" )
Else
'We need to build up the list of groups which needs
'to include any indirect group membership which could
'be the result of assigning a group to be a member of
'another group.

Dim arrGroups
Dim dictGroupNamesByDN

Set dictGroupNamesByDN = CreateObject("Scripting.Dictionary")

arrGroups = oDSRS.Fields(ADS_COLUMN_MEMBEROF).Value

if IsNull( arrGroups ) Then
Trace("--->No groups found")
Else
ProcessGroupMembership( dictGroupNamesByDN, arrGroups )
End If

'Now assing the roles to the user based on
'the nested groups that we just retrieved.

Dim sApplications As String
sApplications = ""

'We also use this opportunity to build the
'workgroup membership up.

Dim sWorkgroup As String
sWorkgroups = ""

Dim sCN As String
Dim sDN As String

Dim keys
keys = dictGroupNamesByDN.Keys

For Each key in keys
sDN = key
sCN = dictGroupNamesByDN.Item(key)

sWorkgroups = sWorkgroups & sCN & ";"

If sCN = CIM_AGENT_APPLICATION_GROUP_NAME Then
sApplications = sApplications & "AGENT;"
End If

If sCN = CIM_RESMAN_APPLICATION_GROUP_NAME Then
sApplications = sApplications & "RESMAN;"
End If

If sCN = CIM_CONFIGMAN_APPLICATION_GROUP_NAME Then
sApplications = sApplications & "CONMAN;"
End If

If sCN = CIM_IVAULT_APPLICATION_GROUP_NAME Then
sApplications = sApplications & "IVAULT;"
End If

If sCN = CIM_DECMAN_APPLICATION_GROUP_NAME Then
sApplications = sApplications & "DMWEB;"
End If

If sCN = CIM_QIM_APPLICATION_GROUP_NAME Then
sApplications = sApplications & "QIM;"
End If

If sCN = CIM_SYSMAN_APPLICATION_GROUP_NAME Then
sApplications = sApplications & "SYSMAN;"
End If
Next


Trace("Roles: " & sApplications)
Trace("Workgroups: " & sWorkgroups)


oRespDS.AddRow
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_USERNAME, sRSUserName)
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_LASTNAME, sRSLastName)
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_FIRSTNAME, sRSFirstName)

If Not IsNull(sRSEMail) Then
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_EMAIL, sRSEmail)
End If

oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_DN, sRSDN)
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_APPLICATIONS, sApplications)
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_WORKGROUPS, sWorkgroups)

If Len(sSLPPrimary) > 0 Then
If IsNull( sRSSLPPrimary ) Then
Trace("Warning: " & sSLPPrimary & " value not populated")
Else
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_SLPPRIMARY, sRSSLPPrimary)
End If
End If

If Len(sSLPSecondary) > 0 Then
If IsNull( sRSSLPSecondary ) Then
Trace("Warning: " & sSLPSecondary & " value not populated")
Else
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_SLPSECONDARY, sRSSLPSecondary)
End If
End If

If Len(sExtension) > 0 Then
If IsNull( sRSExtension ) Then
Trace("Warning: " & sExtension & " value not populated")
Else
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_EXTENSION, sRSExtension)
End If
End If

If Len(sConfiggroup) > 0 Then
If IsNull( sRSConfiggroup ) Then
Trace("Warning: " & sConfiggroup & " value not populated")
Else
oRespDS.SetField(nRow,MSG_USER_QUERY_RESP_CONFIGGROUPS, sRSConfiggroup)
End If
End If

nRow = nRow + 1
End If

oDSRS.MoveNext
Loop


'Clean up
On Error Resume Next

oDSP = Nothing
oDSRS = Nothing

On Error Goto 0
End Sub


Reply ↓  Report •


Ask Question