VBScript to create new users works but fails on assigning folder permissions

Hi the following script works perfectly except for setting the permissions on the users home folder.  Can anyone help with fixing this please?
As an added complexity it sometimes works for one user but then not for the next or further ones?  As this will be part of an HTA I can't use WScript.Sleep
' CreateUsers.vbs

Option Explicit

Dim objExcel, strExcelPath, objSheet, strUser
Dim strLast, strFirst, strMiddle, strPW, intRow, intCol
Dim strGroupDN, objUser, objGroup, objContainer
Dim strCN, strNTName, strContainerDN, strhouseIdentifier
Dim strHomeFolder, strHomeDrive, objFSO, objShell
Dim intRunError, strNetBIOSDomain, strDNSDomain
Dim objRootDSE, objTrans, strLogonScript, strUPN
Dim strdisplayName, strtelephoneNumber, strtitle
Dim strdepartment, strdescription, strphysicalDeliveryOfficeName
Dim strstreetAddress, strcompany, strl, strst
Dim strpostalCode, strc, strco, strwWWHomePage
Dim stro, strdepartmentNumber, strcountryCode
Dim objOU, strattribute

' Constants for the NameTranslate object.
Const ADS_NAME_TYPE_1779 = 1

' Specify spreadsheet.
strExcelPath = "C:\New Starter Scripts\Test\NewUsers1.xlsx"

' Specify DN of container where users created.
strContainerDN = "ou=Newusers,dc=domain.com"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Wscript.Shell")

' Determine DNS domain name from RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")

' Use the NameTranslate object to find the NetBIOS domain name
' from the DNS domain name.
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_INITTYPE_GC, ""
objTrans.Set ADS_NAME_TYPE_1779, strDNSDomain
strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)
' Remove trailing backslash.
strNetBIOSdomain = Left(strNetBIOSDomain, Len(strNetBIOSDomain) - 1)

' Open spreadsheet.
Set objExcel = CreateObject("Excel.Application")

On Error Resume Next
objExcel.Workbooks.Open strExcelPath
If (Err.Number <> 0) Then
    On Error GoTo 0
    Msgbox("Unable to open spreadsheet " & strExcelPath)

End If
On Error GoTo 0
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

' Bind to container where users to be created.
On Error Resume Next
Set objContainer = GetObject("LDAP://" & strContainerDN)
If (Err.Number <> 0) Then
    On Error GoTo 0
    MsgBox("Unable to bind to container: " & strContainerDN)

End If
On Error GoTo 0

' Start with row 2 of spreadsheet.
' Assume first row has column headings.
intRow = 2

' Read each row of spreadsheet until a blank value
' encountered in column 1.
' For each row, create user and set attribute values.
Do While objSheet.Cells(intRow, 1).Value <> ""
    ' Read values from spreadsheet for this user.
    strFirst = Trim(objSheet.Cells(intRow, 1).Value)
    strMiddle = Trim(objSheet.Cells(intRow, 2).Value)
    strLast = Trim(objSheet.Cells(intRow, 3).Value)
    strPW = Trim(objSheet.Cells(intRow, 4).Value)
    strCN = Trim(objSheet.Cells(intRow, 5).Value)
    strNTName = Trim(objSheet.Cells(intRow, 6).Value)
    strUPN = Trim(objSheet.Cells(intRow, 7).Value)
    strHomeFolder = Trim(objSheet.Cells(intRow, 8).Value)
    strHomeDrive = Trim(objSheet.Cells(intRow, 9).Value)
    strLogonScript = Trim(objSheet.Cells(intRow, 10).Value)
    strtitle = Trim(objSheet.Cells(intRow, 11).Value)
    strdepartment = Trim(objSheet.Cells(intRow, 12).Value)
    strdescription = Trim(objSheet.Cells(intRow, 13).Value)
    strphysicalDeliveryOfficeName = Trim(objSheet.Cells(intRow, 14).Value)
    strdisplayName = Trim(objSheet.Cells(intRow, 15).Value)
    strstreetAddress = Trim(objSheet.Cells(intRow, 16).Value)
    strcompany = Trim(objSheet.Cells(intRow, 17).Value)
    strl = Trim(objSheet.Cells(intRow, 18).Value)
    strst = Trim(objSheet.Cells(intRow, 19).Value)
    strpostalCode = Trim(objSheet.Cells(intRow, 20).Value)
    strcountryCode = Trim(objSheet.Cells(intRow, 21).Value)
    strc = Trim(objSheet.Cells(intRow, 22).Value)
    strco = Trim(objSheet.Cells(intRow, 23).Value)
    strwWWHomePage = Trim(objSheet.Cells(intRow, 24).Value)
    stro = Trim(objSheet.Cells(intRow, 25).Value)
    strdepartmentNumber = Trim(objSheet.Cells(intRow, 26).Value)
    strhouseIdentifier = Trim(objSheet.Cells(intRow, 27).Value)
    strtelephoneNumber = Trim(objSheet.Cells(intRow, 28).Value)
    ' Create user object.
    On Error Resume Next
    Set objUser = objContainer.Create("user", "cn=" & strCN)
    If (Err.Number <> 0) Then
        On Error GoTo 0
        MsgBox("Unable to create user with cn: " & strCN)
        On Error GoTo 0
        ' Assign mandatory attributes and save user object.
        If (strNTName = "") Then
            strNTName = strCN
        End If
        objUser.sAMAccountName = strNTName
        On Error Resume Next
        If (Err.Number <> 0) Then
            On Error GoTo 0
            MsgBox("Unable to create user with NT name: " & strNTName)
            ' Set password for user.
            objUser.SetPassword strPW
            If (Err.Number <> 0) Then
                On Error GoTo 0
                MsgBox("Unable to set password for user " & strNTName)
            End If
            On Error GoTo 0
            ' Enable the user account.
            objUser.AccountDisabled = False
            If (strFirst <> "") Then
                objUser.givenName = strFirst
            End If
            ' Assign values to remaining attributes.
            If (strMiddle <> "") Then
                objUser.initials = strMiddle
            End If
            If (strLast <> "") Then
                objUser.sn = strLast
            End If
            If (strUPN <> "") Then
                objUser.userPrincipalName = strUPN
            End If
            If (strHomeDrive <> "") Then
                objUser.homeDrive = strHomeDrive
            End If
            If (strHomeFolder <> "") Then
                objUser.homeDirectory = strHomeFolder
            End If
            If (strLogonScript <> "") Then
                objUser.scriptPath = strLogonScript
            End If
            If (strtitle <> "") Then
            	objUser.title = strtitle
            End If
            If (strdepartment <> "") Then
            	objUser.department = strdepartment
            End If
            If (strdescription <> "") Then
            	objUser.description = strdescription
            End If
            If (strphysicalDeliveryOfficeName <> "") Then
            	objUser.physicalDeliveryOfficeName = strphysicalDeliveryOfficeName
            End If
            If (strdisplayName <> "") Then
            	objUser.displayName = strdisplayName
            End If
            If (strstreetAddress <> "") Then
            	objUser.streetAddress = strstreetAddress
            End If
            If (strcompany <> "") Then
            	objUser.company = strcompany
            End If
            If (strl <> "") Then
            	objUser.l = strl
            End If
            If (strpostalCode <> "") Then
            	objUser.postalCode = strpostalCode
            End If
            If (strcountryCode <> "") Then
            	objUser.countryCode = strcountryCode
            End If
            If (strc <> "") Then
            	objUser.c = strc
            End If
            If (strco <> "") Then
            	objUser.co = strco
            End If
            If (strwWWHomePage <> "") Then
            	objUser.wWWHomePage = strwWWHomePage
            End If
            If (stro <> "") Then
            	objUser.o = stro
            End If
            If (strdepartmentNumber <> "") Then
            	objUser.departmentNumber = strdepartmentNumber
            End If
            If (strhouseIdentifier <> "") Then
            	objUser.houseIdentifier = strhouseIdentifier
            End If
            If (strtelephoneNumber <> "") Then
            	objUser.telephoneNumber = strtelephoneNumber
            End If
            ' Set password expired. Must be changed on next logon.
            objUser.pwdLastSet = 0
            ' Save changes.
            On Error Resume Next
            If (Err.Number <> 0) Then
                On Error GoTo 0
                MsgBox("Unable to set attributes for user with NT name: " _
                    & strNTName)
            End If
            On Error GoTo 0
           'Create home folder.
            If (strHomeFolder <> "") Then
                If (objFSO.FolderExists(strHomeFolder) = False) Then
                   On Error Resume Next
                    objFSO.CreateFolder strHomeFolder
                    If (Err.Number <> 0) Then
                        On Error GoTo 0
                        MsgBox("Unable to create home folder: " & strHomeFolder)
                    End If
                    On Error GoTo 0
                End If       
                If (objFSO.FolderExists(strHomeFolder) = True) Then
                    ' Assign user permission to home folder.
               intRunError = objShell.Run("%COMSPEC% /c Echo Y| cacls """ _
         & strHomeFolder & """ /e /t /c /g """ & strNTName & """:C", 2, True )
           If (intRunError <> 0) Then
         MsgBox("Error assigning permissions for user " _
           & strNTName & " to home folder " & strHomeFolder)
                    End If
                End If
            End If
        End If
    End If
    ' Increment to next user.
    intRow = intRow + 1

Msgbox("Script Completed, if you recieved errors please review the accounts that were mentioned")

' Clean up.
Set objUser = Nothing
Set objContainer = Nothing
Set objSheet = Nothing
Set objExcel = Nothing
Set objFSO = Nothing
Set objShell = Nothing
Set objTrans = Nothing
Set objRootDSE = Nothing

Open in new window

Who is Participating?

Improve company productivity with a Business Account.Sign Up

cochConnect With a Mentor Author Commented:
Thanks for the response.  I appreciate that cacls is outdated, however I dont believe that this is the issue with why it works then doesnt work on the next user in this script.  This appears to be more of a timing issue.  The script loops through the building of the user account and creating the folder then its almost as if its trying to set permissions on the next home folder before the AD account is ready - Is this possible?

I have since updated the script so that it creates the user and home folder and then in the HTA I have added another button to set the permissions on the H drive by writing another script that enumerates all the user accounts in the OU & then reads the home directory path and uses cacls to set the permissions, this works ok
For setting your ACL's, don't pipe it through comspec - just run the app directly, and use a more up to date version of the program.  CACLS is outdated, use ICACLS or Here is sample snippet of code which I run to set home drive permissions:

strShellCommand = "icacls "& strFilePath & " /grant " & strPrincipalName & ":(OI)(CI)(M)"
ShellExec strShellCommand

Sub ShellExec (Cmd)
intResult = objShell.Run(Cmd, 5, True)
	Select Case intResult
		Case 0 
			'Do Nothing
		Case Else
			WScript.Echo "ERROR : Failure with Shell Command, return code : " & intResult
	End Select
End Sub

Open in new window

ICACLS = Windows Vista, 2008 or newer.

If you need clarification for anything, please ask
cochAuthor Commented:
I found a work a round by breaking the acript into 3 sepertae functions in the HTA
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.