An error occurred while using a custom VBScript to create users in active directory users and computers in windows server 2012.
Error Code 8007202f, a Constraint Violation occurred
The .vbs file retrieves data from an Excel file. I used the script to create user accounts once, but when the script was used again for the second time, the error occurred.
Here is the script I used:
'On Error Resume Next
'Make sure to change the OU name as appropriate. Watch about the space after the name.
'Change the domain name also
strOU = "OU=TempOU ,"
strSheet = "C:\staff.xls"
'strPWD = "12345678"
' Bind to Active Directory, Users container.
Set objRootLDAP = GetObject("LDAP://rootDSE")
Set objContainer = GetObject("LDAP://" & strOU & _
objRootLDAP.Get("defaultNamingContext"))
' Open the Excel spreadsheet
Set objExcel = CreateObject("Excel.Application")
Set objSpread = objExcel.Workbooks.Open(strSheet)
intRow = 2 'Skip row for headings
Do Until objExcel.Cells(intRow,1).Value = ""
strCN = Trim(objExcel.Cells(intRow, 1).Value)
strFirst = Trim(objExcel.Cells(intRow, 2).Value)
strSam = Trim(objExcel.Cells(intRow, 3).Value)
strDscpt = Trim(objExcel.Cells(intRow, 4).Value)
strLast = Trim(objExcel.Cells(intRow, 5).Value)
strpasswd=Trim(objExcel.Cells(intRow, 6).Value)
'strpasswd=""
'Principal Name
strPrin = strSam & "#" & "NSBMTEST.com"
'New Container Name and display
strCNnew = strCN
'Created container name as SMB_
Set objUser = objContainer.Create("User", "cn=" & strCNnew)
objUser.userPrincipalName = strPrin
objUser.sAMAccountName = strSam
objUser.givenName = strFirst
'objUser.sn = strLast
objUser.displayName = strCNnew
objUser.Description = strDscpt
objUser.SetInfo
' enable account with password
objUser.userAccountControl = 512
objUser.pwdLastSet = 0
objUser.SetPassword strPWD
objUser.SetPassword strpasswd
objUser.SetInfo
'Pw set to not expire
'Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
'lngFlag = objUser.userAccountControl
' lngFlag = lngFlag Or ADS_UF_DONT_EXPIRE_PASSWD
'objUser.userAccountControl = lngFlag
'objUser.SetInfo
intRow = intRow + 1
Loop
objExcel.Quit
WScript.Quit
Related
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
So, I'm working on an automation project and have stumbled on a roadblock because I can't call anything on a downloaded Excel file.
When I try opening the Excel file manually, its VB Editor is disabled... All other opened Excel files have it enabled.
I'm using below for downloading/opening the said Excel (XLSX) file.
Sub GetLogins()
Application.ScreenUpdating = False
NavSheet.Unprotect [pw]
Dim LoginWkbk As Workbook, LoginWksht As Worksheet
Dim WinHTTPRequest As Object, ADOStream As Object
Dim URL As String
Dim FileRev As Long, LastRow As Long, x As Long
Dim ts As Double
ts = Timer
FileRev = [Revision] ' The current logins file revision
FileRev = FileRev + 1 ' Check for the next revision. Hah!
TryAgain:
If Password = "" Then AcctLoginsForm.Show ' Password not (yet?) supplied
' Second line of security.
If Username = "" Or Password = "" Then
' This checks if the user provided the complete information required.
' If they didn't we would clear the admin logins sheet of any information that was in there.
Call ClearAcctsSheet
MsgBox "Insufficient information submitted.", vbOKOnly, "Window_Title"
GoTo ExitSub
End If
' The logins file URL
URL = "https://mysecreturl" & FileRev & ".xlsx"
Set WinHTTPRequest = CreateObject("Microsoft.XMLHTTP")
With WinHTTPRequest
' "GET" command with username and password
.Open "GET", URL, False, Username, Password
.Send
Select Case .Status
Case 401
' Incorrect credentials.
If MsgBox("Incorrect Username/Password supplied. Try again?", vbYesNo, "Window_Title") = vbYes Then
Call ClearAcctsSheet
Password = ""
GoTo TryAgain
Else
GoTo ExitSub
End If
Case 404
' The next revision is not yet uploaded, so we set to download the previous revision
FileRev = FileRev - 1
GoTo TryAgain
Case 200
' Set the "Revision" named range to the current file revision
[Revision] = FileRev
End Select
Set ADOStream = CreateObject("ADODB.Stream")
ADOStream.Open
ADOStream.Type = 1
ADOStream.Write .ResponseBody
ADOStream.SaveToFile Environ$("temp") & "\logins.xlsx", 2 ' Save the file in the temp file overwriting if the file exists
ADOStream.Close
End With
' Need to clear out the Accounts Sheet fields before populating it with the new credentials
AcctsSheet.Range("A:C").ClearContents
Set LoginWkbk = Workbooks.Open(Environ$("temp") & "\logins.xlsx")
Set LoginWksht = LoginWkbk.Sheets(1)
LastRow = LoginWksht.Cells(Rows.Count, 1).End(xlUp).Row ' Last row. Duh.
For x = 1 To LastRow
' Copy-pasting the information from the logins file crashes Excel, hence this for-loop.
AcctsSheet.Range("A" & x).Value = LoginWksht.Range("A" & x).Value
AcctsSheet.Range("B" & x).Value = LoginWksht.Range("G" & x).Value
AcctsSheet.Range("C" & x).Value = LoginWksht.Range("H" & x).Value
Application.StatusBar = "Extraction complete. Time elapsed: " & Round(Timer - ts, 2)
If LoginWksht.Range("A" & x).Value = "" Then
Exit For
End If
Next x
LoginWkbk.Close False ' Close the logins file
Kill Environ$("temp") & "\logins.xlsx" ' Delete the logins file
[DateToday] = Format(Now, "m/d/yyyy") ' Set the "DateToday" named range to the current day.
ExitSub:
NavSheet.Protect [pw]
NavSheet.Activate
ThisWorkbook.Save
SetToNothing WinHTTPRequest, ADOStream, LoginWkbk, LoginWksht
Application.ScreenUpdating = True
End Sub
I can open the Excel file with Workbooks.Open, but the opened XLSX file is not listed in the VBAProject window so I can't call anything on the sheet.
Has anyone encountered this here? Can we force-enable the macro settings on a single workbook?
A .xlsx file cannot have macros. In my test, the VB editor is not disabled, there are just no macros in the file to show. If you have macros enabled in Excel settings, then the workbook may still need to be in a Trusted Location for Excel to allow macros to run.
I am trying to read a CSV file which is semicolon separated and writing its data to an Excel file cell by cell.
My CSV data is like below:
CATALOG;NAME ;TYPE
---;---;---
test ;Mapping ;BASE
test ;RECEPIENT ;BASE
I am trying to append this data to an Excel using below VBScript code.
Set objShell = WScript.CreateObject ("WScript.Shell")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(objShell.CurrentDirectory & "\" & "Data.xlsx")
'objExcel.Application.Visible = True
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
LastRow = objSheet.UsedRange.Rows.Count
WScript.Echo "LastRow "&LastRow
'objExcel.Cells(LastRow+1, 1).Value = "Test value"
Set objFileToRead = CreateObject("Scripting.FileSystemObject").OpenTextFile(objShell.CurrentDirectory & "\" & "Output.csv",1)
Dim strLine
Do While Not objFileToRead.AtEndOfStream
strResults = objFileToRead.ReadAll
Loop
objFileToRead.Close
Set objFileToRead = Nothing
If Trim(strResults) <> "" Then
' Create an Array of the Text File
arrline = Split(strResults, vbNewLine)
'WScript.Echo UBound(arrline)
End If
For i = 0 To UBound(arrline)
Do
If i = 1 Then Exit Do
If arrline(i) = "" Then
' checks for a blank line at the end of stream
Exit For
End If
ReDim Preserve arrdata(i)
arrdata(i) = Split(arrline(i), ";")
For j = 0 To UBound(arrdata(i))
WScript.Echo Trim(arrdata(i)(j))
'objExcel.Cells(LastRow+1+i,j).Value = Trim(arrdata(i)(j))
Next
Loop While False
Next
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
WScript.Echo "Finished."
WScript.Quit
It is showing the csv data but throwing error
Execl.vbs(41, 6) Microsoft VBScript runtime error: Unknown runtime error
Line number 41 is
objExcel.Cells(LastRow+1+i,j).Value = Trim(arrdata(i)(j))
It works if I put some hardcoded value (5,6 ..) in place of j, but it's not taking j as variable. I can not put any value of j as the number of columns in the input CSV is unknown. Please let me know where I am making a mistake and how to resolve it.
I bet the problem lies with looping through the columns starting at an improper index, column 0. Please try adjusting this line:
For j = 0 To UBound(arrdata(i))
to be
For j = 1 To UBound(arrdata(i))
and make sure to validate that it's not overlooking real data in the far-left column!
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