In a UserForm I've got multiple listboxes.
A list of all Groups in the Active Directory (AD);
A list of selected Groups from ListBox1;
A list of unique members (hence the use of a dictionary since some users can be a member of multiple groups) of these selected groups;
I'm at the point where the first and second lists work fine, however I'm hitting the LDAP administrative limit when the query will return over 1000 records which will return a run-time error 'error -2147016669'. It's this exact problem for reference. Anything below a 1000 and the code will run smooth.
I'm moving in unfamiliar territory and I'm unable to find the correct way to implement the "Page Size" property so that the full list of users will populate the initialized dictionary:
Private Sub Button1_Click()
Set rootDSE = GetObject("LDAP://rootDSE")
domainDN = rootDSE.Get("defaultNamingContext")
Set ado = CreateObject("ADODB.Connection")
ado.Provider = "ADSDSOObject"
ado.Open "ADSearch"
Set Dict_members = CreateObject("Scripting.Dictionary")
For n = 0 To ListBox2.ListCount - 1
If Me.ListBox2.Selected(n) = True Then
ldapFilter = "(sAMAccountName=" & Me.ListBox2.List(n) & ")"
Set objectList = ado.Execute("<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,primaryGroupToken;subtree")
groupDN = objectList.Fields("distinguishedName")
groupRID = objectList.Fields("primaryGroupToken")
ldapFilter = "(|(memberOf=" & groupDN & ")(primaryGroupID=" & groupRID & "))"
Set objectList = ado.Execute("<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,samAccountName,displayname,userPrincipalName;subtree")
While Not objectList.EOF
On Error Resume Next
If Not IsNull(objectList.Fields("userPrincipalName")) Then
Dict_members(objectList.Fields("userPrincipalName").Value) = 1
End If
'logonNameUPN = objectList.Fields("userPrincipalName")
On Error GoTo 0
objectList.MoveNext
Wend
objectList.Close
End If
Next
ado.Close
Me.ListBox3.List = Dict_members.Keys
Me.Label6.Caption = Dict_members.Count
End Sub
I guess the idea is to 'loop' in batches of 1000. Any help is appreciated.
I got it working now; granted I don't know exactly why:
Private Sub Label5_Click()
Set rootDSE = GetObject("LDAP://rootDSE")
domainDN = rootDSE.Get("defaultNamingContext")
Set ado = CreateObject("ADODB.Connection")
ado.Open "Provider=ADsDSOObject;"
Set AdoCmd = CreateObject("ADODB.Command")
AdoCmd.ActiveConnection = ado
AdoCmd.Properties("Page Size") = 1000
Set Dict_members = CreateObject("Scripting.Dictionary")
For n = 0 To ListBox2.ListCount - 1
If Me.ListBox2.Selected(n) = True Then
ldapFilter = "(sAMAccountName=" & Me.ListBox2.List(n) & ")"
AdoCmd.CommandText = "<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,primaryGroupToken;subtree"
Set objectList = AdoCmd.Execute
groupDN = objectList.Fields("distinguishedName")
groupRID = objectList.Fields("primaryGroupToken")
ldapFilter = "(|(memberOf=" & groupDN & ")(primaryGroupID=" & groupRID & "))"
AdoCmd.CommandText = "<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,samAccountName,displayname,userPrincipalName;subtree"
Set objectList = AdoCmd.Execute
While Not objectList.EOF
On Error Resume Next
If Not IsNull(objectList.Fields("userPrincipalName")) Then
Dict_members(objectList.Fields("userPrincipalName").Value) = 1
End If
On Error GoTo 0
objectList.MoveNext
Wend
objectList.Close
End If
Next
ado.Close
Me.ListBox3.List = Dict_members.Keys
Me.Label6.Caption = Dict_members.Count
End Sub
So what is different to the code I initially had used is:
ado.Open "Provider=ADsDSOObject;" instead of ado.Open "ADSearch";
The 'ADODB.Command' to be able to use and set properties. In order to execute properly I also had to initialize the AdoCmd.CommandText, and then execute.
For some reason a more direct:
Set objectList = AdoCmd.Execute("<LDAP://" & domainDN & ">;" & ldapFilter & ";distinguishedName,primaryGroupToken;subtree")
Would yield an error.
This is the result of some trial and error, but it works flawlessly now and will return thousands and thousands of users if need be.
You may be working too hard with this code. If it were me, I'd pull back all the columns I wanted from Active Directory using Power Query and then just use normal Excel table and Pivot operations.
Data > Get Data > From Other Sources > From Active Directory
Related
I have an Access VBA loop that creates an Excel spreadsheet with multiple worksheets using a TransferSpreadsheet command. This has worked for several years but now I only see one worksheet.
It seems to create the sheets but overwrite the previous one instead of adding another.
There are no errors and the code runs through but when the code activates the spreadsheet after the formatting has been done there is just the last sheet created.
Any ideas? Is this the result of a Microsoft update with unintended consequences?
There is a loop which runs a variable number of times creating a worksheet each time:
r.MoveFirst
ok = True
Do While ok
tempMth = r!mth
tempyr = r!yr
strSQL = "SELECT * FROM BkgsSummarySS WHERE mth = '" & tempMth & "' AND yr = '" & tempyr & "'"
Set qdf = db.QueryDefs(strTemp)
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, strTemp, SpLocation, True, strTemp
DoCmd.RunSQL ("UPDATE bkgsSummarySS SET [party date] = #01/01/2000# WHERE mth = '" & tempMth & "' AND yr = '" & tempyr & "'")
Set r = db.OpenRecordset("SELECT * FROM bkgsSummarySS ORDER BY [Party Date] DESC")
r.MoveFirst
If r![party date] = #1/1/2000# Then ok = False
Loop
r.Close
db.QueryDefs.Delete strTemp
Set objApp = CreateObject("Excel.Application")
objApp.UserControl = True
objApp.workbooks.Open (SpLocation)
There are then lots of formatting lines, which all still work followed by:
objApp.Visible = True
I'm pretty sure its the Excel end that is the problem. How do I tell it to add a worksheet every time the TransferSpreadsheet command is executed - it did do this until a few weeks ago?
I'm trying to import all data from 3 columns in an access database (.mdb) into my Excel file, which is working, however the numbers that I'm importing aren't coming in correct. You can see in the images supplied what exactly is happening. I am wanting it to import exactly as it is in the database (to 1 decimal place). Now I've tried with changing the numberformat for the Excel columns but of course that only hides the true value with a shortened version so I'd like to avoid doing that.
Dealing with SQL in VBA is something new to me and I don't know Access very well either so I'm wondering if there is something I can add to the query that could affect why the numbers are changing when they get copied into my Excel sheet.
I'm going to be adding a lot more to the code later but just testing connection for now to get it working properly first.
Here is my code (Got the basis for it from a youtube video I found):
Sub GetDataFromAccess()
Application.screenupdating = False
On Error GoTo SubError
Dim db As DAO.Database, rs As DAO.Recordset, xlSheet As Worksheet, recCount As Long, SQL As String, _
TableName As String, FldrLoc As String, FileName As String, ImpSh As Worksheet
Set ImpSh = Sheets("Import")
FldrLoc = ImpSh.Range("D10").Value
FileName = ImpSh.Range("Q15").Value
If Right(FldrLoc, 1) = "\" Then
DbLoc = FldrLoc & FileName
Else
DbLoc = FldrLoc & "\" & FileName
End If
Set xlSheet = Sheets("CAL-53 INC")
If InStr(ImpSh.Range("Q15").Value, ".mdb") > 0 Then
TableName = ImpSh.Range("R5").Value & Left(ImpSh.Range("Q15").Value, Len(ImpSh.Range("Q15")) - 4)
Else
TableName = ImpSh.Range("R5").Value & ImpSh.Range("Q15").Value
End If
xlSheet.Range("G3:I5000").ClearContents
Application.StatusBar = "Connecting to the database..."
Application.Cursor = xlWait
Set db = OpenDatabase(DbLoc)
SQL = "SELECT LRP_CHAINAGE, LEFT_DEPTH, RIGHT_DEPTH" & _
" FROM " & TableName & " ORDER BY LRP_CHAINAGE "
Set rs = db.OpenRecordset(SQL, dbOpenSnapshot)
Application.StatusBar = "Writing to spreadsheet..."
If rs.RecordCount = 0 Then
MsgBox "No data from that table"
GoTo SubExit
Else
rs.MoveLast
recCount = rs.RecordCount
rs.MoveFirst
End If
xlSheet.Range("G3").CopyFromRecordset rs
'xlSheet.Range("G:I").NumberFormat = "0.0"
Application.StatusBar = "Update complete."
SubExit:
On Error Resume Next
Application.Cursor = xlDefault
rs.Close
Set rs = Nothing
Set xlSheet = Nothing
Application.screenupdating = True
Exit Sub
SubError:
Application.StatusBar = ""
MsgBox "Error: " & vbCrLf & Err.Number & " = " & Err.Description
Resume SubExit
End Sub
Here are the pictures of what is in the database and what it's coming in as:
As a quick work around you may set the SQL statement as follows:
SQL = "SELECT Fix(10*[" & TableName & "]![LRP_CHAINAGE])/10 AS LRP_CHAINAGE, Fix(10*[" & TableName & "]![LEFT_DEPTH])/10 AS LEFT_DEPTH, Fix(10*[" & TableName & "]![RIGHT_DEPTH])/10 AS RIGHT_DEPTH" & _
" FROM " & TableName & " ORDER BY LRP_CHAINAGE "
This will give you only one digit after decimal. If you need two digits just change multiplier and divider to 100 :)
SQL = "SELECT LRP_CHAINAGE*10, LEFT_DEPTH*10, RIGHT_DEPTH*10" & _
" FROM " & TableName & " ORDER BY LRP_CHAINAGE "
I'm not running access or windows, but I remember I've done something like this with sql server and excel since vba truncate decimal values
After this query, you can use an update query on the worksheet
UPDATE [IMPORT$]
SET LRP_CHAINAGE=LRP_CHAINAGE/10, LEFT_DEPTH/10, RIGHT_DEPTH/10
I am automating a report, and the hierarchy is always subject to change. Since people who will be using this macro have no coding skills I have been creating a new report. But recently I got stuck on this part. I have a sheet where the user can enter the hierarchy. Then the code loops through the hierarchy added and saves it in a method that I thought would work in an array. It will run but when it gets to the filter part I get the error: The object invoked has disconnected from its clients
I originally had the hierarchy in the code before but I do not want the users to touch the code. When it was in the code It worked perfectly. The way I am doing it now appears to match what I had done before but am once again having issues
Private Sub CommandButton1_Click()
Set wa = ThisWorkbook.Worksheets("Sheet2")
Set wt = ThisWorkbook.Worksheets("Sheet1")
lastrow = wa.Cells(Rows.Count, 1).End(xlUp).Row
lastrow99 = wt.Cells(Rows.Count, 1).End(xlUp).Row
For Each a In wt.Range("A2:A" & lastrow99)
If IMRCCSpec1 = Empty Then
IMRCCSpec1 = a.Cells.Value
Else
IMRCCSpec1 = IMRCCSpec1 & """" & ", " & """" & a.Cells.Value
End If
Next a
lastrow99 = wt.Cells(Rows.Count, 2).End(xlUp).Row
For Each a In wt.Range("B2:B" & lastrow99)
If IMRCCSup1 = Empty Then
IMRCCSup1 = a.Cells.Value
Else
IMRCCSup1 = IMRCCSup1 & """" & ", " & """" & a.Cells.Value
End If
Next a
IMRRCCSpec = Array(IMRCCSpec1)
IMRRCCSup = Array(IMRCCSup1)
wa.Range("A1:U" & lastrow).Sort Key1:=wa.Range("D1:D" & lastrow), Order1:=xlAscending, Header:=xlYes
wa.Range("A1:U" & lastrow).AutoFilter field:=6, Criteria1:=IMRCCSpec, Operator:=xlFilterValues
End Sub
I would like for the the code to actually filter based on what the hierarchy is
I'm having trouble with some VBA programming since I'm totally new to it.
I've been given the task to create a macro/vba application in Word/excel that retrieves Lastname, Firstname | telephone number | Department | Manager from the Active Directory.
So I've been searching the internet for the last days but nothing really works for me.
A Template that gets the current Users First-/Lastname, email etc. was given to work on. I am having a hard time on transferring the code to what i need to do now.
So what I've been trying for the past hours now, was getting a list of all the Users from the Active Directory. But the Code I use was from a VBScript I found on the internet. I changed what I could to make it work with VBA but I always get an error when trying to run it.
The code is the following:
Sub test()
' get OU
'
strOU = "OU=Users,DC=domain,DC=com"
' connect to active directory
'
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
' create command
'
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
' execute command to get all users
'
objCommand.commandtext = "LDAP://" & strOU & ">;" & _
"(&(objectclass=user)(objectcategory=person));" & _
"adspath,distinguishedname,sAMAccountName;subtree"
On Error Resume Next
Set objRecordSet = objCommand.Execute
If Err.Number <> 0 Then MsgBox "Exception occured: " & Err.Description
On Error GoTo 0
'Dim RecordSet As New ADODB.RecordSet
Set objRecordSet = objCommand.Execute
'Show info for each user in OU
'
Do Until objRecordSet.EOF
'Show required info for a user
'
Debug.Print obj.RecordSet.Fields(“adspath”).Value
Debug.Print obj.RecordSet.Fields(“distinguishedname”).Value
Debug.Print obj.RecordSet.Fields(“sAMAccountName”).Value
' Move to the next user
'
obj.RecordSet.MoveNext
Loop
' Clean up
'
obj.RecordSet.Close
Set obj.RecordSet = Nothing
Set objCommand = Nothing
objConnection.Close
Set objConnection = Nothing
End Sub
and in this line it all stops everytime:
Set objRecordSet = objCommand.Execute
if I remove the If Err.Number <> 0 Then MsgBox "Exception occured: " & Err.Description
On Error GoTo 0 part it just freezes and crashes word.
OK, let's go top down:
strOU = "OU=Users,DC=domain,DC=com"
With this nobody can help you. You must know the AD structure of your AD. If this is wrong, then you get "Table not found" from LDAP.
objCommand.commandtext = "LDAP://" & strOU & ">;" & _
"(&(objectclass=user)(objectcategory=person));" & _
"adspath,distinguishedname,sAMAccountName;subtree"
This lacks a <. It should be:
objCommand.commandtext = "<LDAP://" & strOU & ">;" & _
"(&(objectclass=user)(objectcategory=person));" & _
"adspath,distinguishedname,sAMAccountName;subtree"
Then
Debug.Print obj.RecordSet.Fields(“adspath”).Value
Debug.Print obj.RecordSet.Fields(“distinguishedname”).Value
Debug.Print obj.RecordSet.Fields(“sAMAccountName”).Value
Multiple problems here:
Typographically double quotes are not allowed as string delimiter in VBA source code.
Your Object is named objRecordset and not obj.Recordset.
So this should be:
Debug.Print objRecordset.Fields("adspath").Value
Debug.Print objRecordset.Fields("distinguishedname").Value
Debug.Print objRecordset.Fields("sAMAccountName").Value
Replace obj.Recordset with objRecordset also in the rest of the code.
I need to modify the expiry date on Active Directory user accounts, taking the account name and date to set from data that is in Excel.
I have the below VBScript to set an AD expiry date, but I can't work out how to change it so that it takes the account name and date to set as the expiry from particular cells in Excel.
The aim is to provide easy bulk administration of this task that we have to do daily.
Set objUser = GetObject _
("LDAP://cn=Joe.Bloggs,ou=Management,dc=AN,dc=Franz,dc=com")
objUser.AccountExpirationDate = "10/30/2014"
objUser.SetInfo
Your sample code requires a distinguished name, so you need to resolve the account name to the user object's distinguished name:
acct = "..." 'account name
Set rootDSE = GetObject("LDAP://rootDSE")
base = "<LDAP://" & rootDSE.Get("DefaultNamingContext") & ">"
filter = "(&(objectClass=user)(objectCategory=person)(sAMAccountName=" _
& acct & "))"
attr = "distinguishedName"
scope = "subtree"
Set conn = CreateObject("ADODB.Connection")
conn.Provider = "ADsDSOObject"
conn.Open "Active Directory Provider"
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = conn
cmd.CommandText = base & ";" & filter & ";" & attr & ";" & scope
Set rs = cmd.Execute
Do Until rs.EOF
dn = rs.Fields("distinguishedName").Value
rs.MoveNext
Loop
WScript.Echo dn
Since AD queries require quite a bit of boilerplate code, and I got tired of having to write it over and over again, I wrapped it in a reusable VBScript class (ADQuery). With this class you can simplify the query to the following:
'<-- copy/paste class code here
acct = "..." 'account name
Set qry = New ADQuery
qry.Filter = "(&(objectClass=user)(objectCategory=person)(sAMAccountName=" _
& acct & "))"
Set rs = qry.Execute
Do Until rs.EOF
dn = rs.Fields("distinguishedName").Value
rs.MoveNext
Loop
WScript.Echo dn
Replace the distinguished name in the code you copied from ActiveXperts with the variable dn:
objUser = GetObject("LDAP://" & dn)
objUser.AccountExpirationDate = "10/30/2014"
objUser.SetInfo
The account names can be read from an Excel sheet with something like this (provided you have Excel installed):
Set xl = CreateObject("Excel.Application")
Set wb = xl.Workbooks.Open("C:\path\to\your.xlsx")
Set range = wb.Sheets(1).UsedRange
For i = range.Rows(1).Row To range.Rows(range.Rows.Count).Row
acct = range.Cells(i, 1).Value
'rest of your code here
Next
wb.Close
xl.Quit