none
Creating User Folders with 3 nested folders and permissions

    Question

  • Title:

    Need a script to create user folders with three nested folders and set appropriate security for each

    Question: Hello,
    Looking to create a folder for each user with the following perms in place on each folder
    Username <-- All have list with domain admins as folder owner
         Public <--  All have read and write access on this folder
         Private <--only the user has access  READ, WRITE, EDIT
         Dropbox  <-- user has full access others can only write to this folder
    I would like to be able to script this but am open to software solutions as well.
    My previous solution of creating these folders with a good old perl script don't work any longer on server 2008
    help!!
    Thursday, June 24, 2010 3:01 AM

Answers

  • Hi Joe

    Here is an example for you, i've added more functionality, logging and error checking. You may wish to tweak the icacls commands to ensure the NTFS permissions meet your requirements.

    Copy the code below as "CreateHomeFolders.vbs" and save it to a directory EG the "C:\Scripts\CreateHomeFolders.vbs" on the server which will host the user's homefolders. Create a file named "UserNames.txt" with the "C:\Scripts" folder that containing the users logon name (sAMAccountName) to create home directorys for. I'd suggest you add one user to the text file and test it first to ensure the permissions meet your requirements. I tested this on VM (Server 2008 DC) and worked fine so let me know if you have any issues.

    One last recommendation...I'd strongly advise you change the group you assign full control permissions to from "Domain Admins" to another group. I'd suggest creating a seperate AD global security group EG "Homedrive Data Administrators" and assign full control to that group instead of "Domain Admins". This will ensure there is a seperation of administrative responsibility between administrators who actually require administrative privellages in AD as oppossed to those who just need to manage data and NTFS permissions otherwise you may find yourself having to add users to the domain admins group just so they can manage data!

    Hope this helps

    Cheers Matt :)

    '-------------------------------------------------------------------------------------------------
    'Script Name : CreateHomeFolders.vbs  
    'Author   : Matthew Beattie
    'Created   : 26/06/10  
    'Description : This script reads a text file from the scripts working directory named "UserNames.txt"
    '      : The text file contains a list of Active Directory user names to creates a home folder 
    '      : structure for and assigns NTFS permissions using the icacls.exe utility.
    '      : All results are logged within the scripts directory.
    '      : 
    '      : Creates a folder for each user with the following NTFS Permissions on each folder
    '      : 
    '      : %Username% <- (Domain Users have List\Traverse folder permissions. Domain Admins have full control)
    '      :  Public  <- (Domain Admins Full Control, Domain Users have read only. User has modify access on this folder)
    '      :  Private <- (Domain Admins Full Control, User has Modify Access)
    '      :  DropZone <- (Domain Admins Full Control, User has Modify. Domain Users have write only acces)
    '-------------------------------------------------------------------------------------------------
    'Initialization Section  
    '-------------------------------------------------------------------------------------------------
    Option Explicit  
    Const ForReading  = 1  
    Const ForWriting  = 2  
    Const ForAppending = 8  
    Dim objFSO, wshShell, wshNetwork  
    Dim scriptBaseName, scriptPath, scriptLogPath
    On Error Resume Next 
      Set objFSO   = CreateObject("Scripting.FileSystemObject")   
      Set wshNetwork = Wscript.CreateObject("Wscript.Network")  
      Set wshShell  = CreateObject("Wscript.Shell")  
      scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)  
      scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path  
      scriptLogPath  = scriptPath & "\" & scriptBaseName 
      If Err.Number <> 0 Then
       MsgBox "An Unexpected Error Occurred creating global variables", vbCritical 
       Wscript.Quit  
      End If
    On Error Goto 0
    '-------------------------------------------------------------------------------------------------
    'Main Processing Section  
    '-------------------------------------------------------------------------------------------------
    On Error Resume Next
      PromptStart
      ProcessScript  
      If Err.Number <> 0 Then
       PromptError "Processing Script"
       Wscript.Quit
      End If
      PromptEnd
    On Error Goto 0  
    '-------------------------------------------------------------------------------------------------
    'Functions Processing Section
    '-------------------------------------------------------------------------------------------------
    'Name    : ProcessScript -> Primary Function that controls all other script processing.
    'Parameters : None     ->
    'Return   : None     ->
    '-------------------------------------------------------------------------------------------------
    Function ProcessScript
      Dim fileSpec, folderSpec, folderNames, userNames
      fileSpec  = scriptPath & "\UserNames.txt"
      folderSpec = "C:\Data\Users"
      folderNames = Array("Public","Private","DropZone")
      '----------------------------------------------------------------------------------------------
      'Ensure the Script input file exists.
      '----------------------------------------------------------------------------------------------
      If Not objFSO.FileExists(fileSpec) Then
       MsgBox DQ(fileSpec) & " does not exist!", vbCritical, scriptBaseName
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Read the list of user's from the script's input file.
      '----------------------------------------------------------------------------------------------
      If Not GetScriptInput(userNames, fileSpec) Then
       MsgBox "Failed to read the file " & DQ(fileSpec), vbCritical, scriptBaseName
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Create the folder structure and set the NTFS permissions for each user and sub folders.
      '----------------------------------------------------------------------------------------------
      If Not CreateHomeFolders(userNames, folderNames, folderSpec) Then
       Exit Function
      End If
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : CreateHomeFolders -> Primary Function that controls all other script processing.
    'Parameters : userNames     -> Array containing usernames to create homefolders for.
    '      : folderNames    -> Array containing folder names of sub folders to create.
    '      : folderSpec    -> String containing the root folder to create the homefolders in.
    'Return   : CreateHomeFolders -> Returns True if all homefolders were created otherwise False.
    '-------------------------------------------------------------------------------------------------
    Function CreateHomeFolders(userNames, folderNames, folderSpec)
      Dim commands, command, timeOut, errorCount
      Dim userName, folderName, folderPath
      CreateHomeFolders = False
      timeOut      = 10
      errorCount    = 0
      '----------------------------------------------------------------------------------------------
      'Ensure the usernames and folderNames parameters are valid arrays
      '----------------------------------------------------------------------------------------------
      If Not IsArray(userNames) And Not IsArray(folderNames) Then
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Ensure the root folder to create the user's home directories in exists.
      '----------------------------------------------------------------------------------------------
      If Not objFSO.FolderExists(folderSpec) Then
       If Not CreateFolder(folderSpec) Then
         Exit Function
       End If
      End If
      '----------------------------------------------------------------------------------------------
      'Create Each users home directory folder and set their NTFS Permissions.
      '----------------------------------------------------------------------------------------------
      For Each userName In userNames
       folderPath = folderSpec & "\" & userName
       Do
         '----------------------------------------------------------------------------------------
         'Create the user's root home folder
         '----------------------------------------------------------------------------------------
         If Not CreateFolder(folderSpec & "\" & userName) Then
          errorCount = errorCount + 1
          Exit Do
         End If
         LogMessage 0, "Successfully Created folder " & DQ(folderPath)
         '----------------------------------------------------------------------------------------
         'Create the sub folders within the users home directory and set the NTFS permissions.
         '----------------------------------------------------------------------------------------
         For Each folderName In folderNames
          folderPath = folderSpec & "\" & userName & "\" & folderName
          '-------------------------------------------------------------------------------------
          'Select the command to execute to set the NTFS permissions for each sub folder.
          '-------------------------------------------------------------------------------------
          Select Case folderName
            Case "Public"
             commands = Array("icacls.exe " & DQ(folderPath) & " /Inheritance:R", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Admins") & ":(CI)(OI)F", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Users") & ":(CI)(OI)RX", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ(userName)    & ":(CI)(OI)M")
            Case "Private"
             commands = Array("icacls.exe " & DQ(folderPath) & " /Inheritance:R", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Admins") & ":(CI)(OI)F", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ(userName)    & ":(CI)(OI)M")
            Case "DropZone"
             commands = Array("icacls.exe " & DQ(folderPath) & " /Inheritance:R", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Admins") & ":(CI)(OI)F", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Users") & ":(CI)(OI)W", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ(userName)    & ":(CI)(OI)M")
            Case Else
             Exit For
          End Select
          '-------------------------------------------------------------------------------------
          'Create Each sub folder.
          '-------------------------------------------------------------------------------------
          Do
            If Not CreateFolder(folderPath) Then
             errorCount = errorCount + 1
             Exit Do
            End If
            LogMessage 0, "Successfully Created folder " & DQ(folderPath)
            '----------------------------------------------------------------------------------
            'Execute each command to set the NTFS permissions on the sub folder.
            '----------------------------------------------------------------------------------
            For Each command In commands
             Do
               If Not SetACL(folderPath, command, timeOut) Then
                errorCount = errorCount + 1
                Exit Do
               End If
               LogMessage 0, "Successfully processed command: " & command
             Loop Until True
            Next
          Loop Until True
         Next
       Loop Until True
      Next
      '----------------------------------------------------------------------------------------------
      'Ensure the Function returns False if any errors have occurred.
      '----------------------------------------------------------------------------------------------
      If errorCount <> 0 Then
       Exit Function
      End If
      CreateHomeFolders = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : SetACL   -> Recursive Function to Create a directory structure or single folder.
    'Parameters : folderPath -> String containing the Path of folder to configure the access control list on.
    '      : command  -> String containing the icacls command used to configure the access control list.
    '      : timeOut  -> Integer containing the number of seconds to wait for the command to complete before exiting.
    'Return   : SetACL   -> Returns True if ACL was successfully configured otherwise returns False.
    '-------------------------------------------------------------------------------------------------
    Function SetACL(folderPath, command, timeOut)
      Dim results, errors, errorCount, i
      SetAcl   = False
      errorCount = 0
      '----------------------------------------------------------------------------------------------
      'Process the icacls command to set the NTFS permissions.
      '----------------------------------------------------------------------------------------------
      If Not RunCommand(results, command, timeOut) Then
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Process the output results of the icacls command.
      '----------------------------------------------------------------------------------------------
      For i = 0 To UBound(results)
       Do
         '----------------------------------------------------------------------------------------
         'Search for the semi colon character in each line of the icacls command output.
         '----------------------------------------------------------------------------------------
         If InStr(1, results(i), ";", vbTextCompare) <> 0 Then
          On Error Resume Next
            '----------------------------------------------------------------------------------
            'Find the number of errors in the icalcs command output.
            '----------------------------------------------------------------------------------
            errors = CInt(Trim(Replace(Replace(Split(results(i), ";")(1), "Failed processing", ""), "files", "")))
            If Err.Number <> 0 Then
             LogError 1, "Splitting string " & DQ(results(i))
             errorCount = errorCount + 1
             Exit Do
            End If
          On Error Goto 0
          '-------------------------------------------------------------------------------------
          'Ensure the Function returns False if the icacls command output contained any errors.
          '-------------------------------------------------------------------------------------
          If errors <> 0 Then
            Exit Function
          End If
         End If
       Loop Until True
      Next
      If errorCount <> 0 Then
       Exit Function
      End If
      SetAcl = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : CreateFolder -> Recursive Function to Create a directory structure or single folder.
    'Parameters : folderSpec  -> Path of folder\folders to create.
    'Return   : CreateFolder -> Returns True if the directory structure was successfully created otherwise False.
    '-------------------------------------------------------------------------------------------------
    Function CreateFolder(folderSpec)
      CreateFolder = False
      If Not objFSO.FolderExists(folderSpec) Then
       If InStrRev(folderSpec, "\") <> 0 Then
         If Not CreateFolder(Left(folderSpec, InStrRev(folderSpec, "\") - 1)) Then
          Exit Function
         End If
       End If
       On Error Resume Next
         objFSO.CreateFolder folderSpec
         If Err.Number <> 0 Then
          LogMessage 1, "Creating folder " & DQ(folderSpec)
          Exit Function
         End If
       On Error Goto 0
      End If
      CreateFolder = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : RunCommand -> Executes a command.
    'Parameters : output   -> Input/Output : An array containing the Output resulting from the command.
    '      : command  -> String containting the command to execute.
    '      : timeout  -> Integer containing the Timeout value in seconds to wait for the command to complete.
    'Return   : RunCommand -> Returns True if command was successful otherwise returns False.
    '-------------------------------------------------------------------------------------------------
    Function RunCommand(output, command, timeout)
      Dim objExec, waited
      RunCommand = False
      output   = ""
      waited   = 0
      '----------------------------------------------------------------------------------------------
      'Execute the command.
      '----------------------------------------------------------------------------------------------
      On Error Resume Next
       Set objExec = wshShell.Exec(command)
       If Err.Number <> 0 Then
         LogMessage 1, "Executing command " & DQ(command)
         Exit Function
       End If
      On Error Goto 0
      '----------------------------------------------------------------------------------------------
      'Wait until the command has completed or the the timout is exceeded.
      '----------------------------------------------------------------------------------------------
      Do Until objExec.status = 1 Or (waited >= timeout And timeout > 0)
       output = output & objExec.StdOut.ReadAll
       Wscript.Sleep 100
       waited = waited + 100
      Loop
      '----------------------------------------------------------------------------------------------
      'Remove empty lines from the output string before converting to an Array.
      '----------------------------------------------------------------------------------------------
      Do While InStr(output, vbNewLine & vbNewLine) <> 0
       output = Replace(output, vbNewLine & vbNewLine, vbNewLine)
      Loop
      If Left(output, 1) = vbNewLine Then
       output = Mid(output, 2)
      End If
      If Right(output, 1) = vbNewLine Then
       output = Left(output, Len(output) -1)
      End If
      output = ToArray(output, vbNewLine)
      RunCommand = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : DQ     -> Place double quotes around a string and replace double quotes
    '      :       -> within the string with pairs of double quotes.
    'Parameters : stringValue -> String value to be double quoted
    'Return   : DQ     -> Double quoted string.
    '-------------------------------------------------------------------------------------------------
    Function DQ(ByVal stringValue)
      If stringValue <> "" Then
       DQ = """" & Replace(stringValue, """", """""") & """"
      Else
       DQ = """"""
      End If
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : ToArray  -> Checks the list value to determine if the Array is Empty.
    'Parameters : list   -> String value to check for Array conversion.
    'Parameters : delimiter -> value to use to split the string into an Array.
    'Return   :      -> Returns the an Empty Array if the list value if blank
    '      :      -> else splits the string value into an Array.
    '-------------------------------------------------------------------------------------------------
    Function ToArray(list, delimiter)
      If list = "" Then
       ToArray = Array
      Else
       ToArray = Split(list, delimiter)
      End If
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : NewDictionary -> Creates a new dictionary object.
    'Parameters : None     ->
    'Return   : NewDictionary -> Returns a dictionary object.
    '-------------------------------------------------------------------------------------------------
    Function NewDictionary
      Dim dict
      Set dict     = CreateObject("scripting.Dictionary")
      dict.CompareMode = vbTextCompare
      Set NewDictionary = dict
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : GetScriptInput -> Reads a text file to be used as the scripts input into a dictionary object.
    '      :        -> Each line of the text file is added to a Dictionary object. Duplicate lines are ignored.
    'Parameters : results    -> Input/Output : An array of unique items read from the text file.
    '      : fileSpec    -> String containing the folder path and file name of the script input file.
    'Return   : GetScriptInput -> Returns false if the user input file is invalid else returns true.
    '-------------------------------------------------------------------------------------------------
    Function GetScriptInput(results, fileSpec)
      Dim objTextFile, objDict, line
      GetScriptInput = False
      Set objDict  = NewDictionary
      On Error Resume Next
       Set objTextFile = objFSO.OpenTextFile(fileSpec, ForReading)
       If Err.Number <> 0 Then
         BuildMessage 1, "Opening Text File " & DQ(fileSpec)
         Exit Function
       End If
       Do Until objTextFile.AtEndOfStream
         line = objTextFile.Readline
         If Err.Number <> 0 Then
          BuildMessage 1, "Reading a line from within the file " & DQ(fileSpec)
          Exit Function
         End If
         If Not objDict.Exists(line) Then
          objDict(objDict.Count) = line
         End If
       Loop
      On Error Goto 0
      GetScriptInput = True
      results    = objDict.Items
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : LogMessage -> Parses a message to the log file based on the messageType.  
    'Parameters : messageType -> Integer representing the messageType.
    '      :       -> 0 = message    (writes to a ".log" file)
    '      :       -> 1 = error,    (writes to a ".err" file including information relating to the error object.)
    '      :       -> 2 = error message (writes to a ".err" file without information relating to the error object.)
    '      : message   -> String containing the message to write to the log file.
    'Return   : None    -> 
    '-------------------------------------------------------------------------------------------------
    Function LogMessage(messageType, message)
      Dim logType
      Select Case messageType
       Case 0
         logType = "log"
       Case 1
         logType = "err"
         message = "Error " & Err.Number & " (Hex " & Hex(Err.Number) & ") " & message & ". " & Err.Description
       Case Else
         LogType = "err"
      End Select
      If Not LogToFile(scriptLogPath & "." & logType, message) Then 
       Exit Function 
      End If
    End Function 
    '-------------------------------------------------------------------------------------------------
    'Name    : LogToFile -> Write a message into the user's network log file.  
    'Parameters : LogSpec  -> String containing the Folder path, file name and extension of the log file to write to.  
    '      : message  -> String containing the Message to be logged.  
    'Return   : LogToFile -> Returns True if successful otherwise returns false.  
    '-------------------------------------------------------------------------------------------------
    Function LogToFile(logSpec, message)  
      LogToFile = False 
      On Error Resume Next 
       With objFSO.OpenTextFile(logSpec, ForAppending, True)  
         .WriteLine Date & " " & Time & " " & message
         .Close  
       End With 
       If Err.Number <> 0 Then 
         Exit Function 
       End If 
      On Error Goto 0  
      LogToFile = True 
    End Function 
    '-------------------------------------------------------------------------------------------------
    'Name    : PromptStart -> Prompt when script starts.
    'Parameters : None    ->
    'Return   : None    ->
    '-------------------------------------------------------------------------------------------------
    Function PromptStart
      MsgBox "Now processing the " & DQ(Wscript.ScriptName) & " script.", vbInformation, scriptBaseName
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : PromptEnd -> Prompts when script has completed.
    'Parameters : None   ->
    'Return   : None   ->
    '-------------------------------------------------------------------------------------------------
    Function PromptEnd
      MsgBox "The " & DQ(Wscript.ScriptName) & " script has completed successfully.", vbInformation, scriptBaseName
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : PromptError -> Prompts when an unexpected script error occurs.
    'Parameters : None    ->
    'Return   : None    ->
    '-------------------------------------------------------------------------------------------------
    Function PromptError
      MsgBox "Error " & Err.Number & " (Hex " & Hex(Err.Number) & "). " & Err.Description, vbCritical, scriptBaseName
    End Function
    '-------------------------------------------------------------------------------------------------
    Saturday, June 26, 2010 6:28 AM

All replies

  • Hi,

    Here is a script to create your folder structure for each user. You can then add to this to shell out to either xcacls.exe or icacls.exe on server 2008 to set the permissions for each user\folder.

    Hope that helps

    Cheers Matt :)

    Option Explicit
    Dim objFSO
    On Error Resume Next
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     ProcessScript
     If Err.Number <> 0 Then
      Wscript.Quit
     End If
    On Error Goto 0
    '-------------------------------------------------------------------------------------------------
    'Functions Processing Section
    '-------------------------------------------------------------------------------------------------
    'Name  : ProcessScript -> Primary Function that controls all other script processing.
    'Parameters : None   ->
    'Return  : None   ->
    '-------------------------------------------------------------------------------------------------
    Function ProcessScript
     Dim userNames, userName
     Dim folderSpec, folderNames, folderName 
     folderSpec = "C:\Data\Homedrives"
     userNames = Array("user1","user2","user3")
     folderNames = Array("Public","Private","Dropbox")
     '----------------------------------------------------------------------------------------------
     'Create the folder structure for each user.
     '----------------------------------------------------------------------------------------------
     For Each userName In userNames
      Do
       If Not CreateFolder(folderSpec & "\" & userName) Then
       Exit Do
       End If
       For Each folderName In folderNames
       Do
        If Not CreateFolder(folderSpec & "\" & userName & "\" & folderName) Then
         Exit Do
        End If
       Loop Until True
       Next
      Loop Until True
     Next
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name  : CreateFolder -> Recursive Function to Create a directory structure or single folder.
    'Parameters : folderSpec -> Path of folder\folders to create.
    'Return  : CreateFolder -> Returns True if the directory structure was successfully created otherwise False.
    '-------------------------------------------------------------------------------------------------
    Function CreateFolder(folderSpec)
     CreateFolder = False
     If Not objFSO.FolderExists(folderSpec) Then
      If InStrRev(folderSpec, "\") <> 0 Then
       If Not CreateFolder(Left(folderSpec, InStrRev(folderSpec, "\") - 1)) Then
       Exit Function
       End If
      End If
      On Error Resume Next
       objFSO.CreateFolder folderSpec
       If Err.Number <> 0 Then
       Exit Function
       End If
      On Error Goto 0
     End If
     CreateFolder = True
    End Function
    '-------------------------------------------------------------------------------------------------
    Thursday, June 24, 2010 4:03 AM
  • Matt, this is great and gets me to the next leg of my journey. how do I get it go look at a csv for a mass userlist and do you have any examples of  shelling out to either xcacls.exe or icacls.exe on server 2008. My coding experience is mapping drives.. lol 

    Thank you for your time and expertise!

    Sincerely,

    Joe

     

    Friday, June 25, 2010 12:06 PM
  • Hi Joe

    Sure here is an example from a previous script i've posted on creating home folders and setting their NTFS permissions using icacls.exe. This also contains the code for reading the script's input from a file:

    http://social.technet.microsoft.com/Forums/en-US/ITCG/thread/e31b7f03-7bc7-4a40-826e-55ab05bb5429

    I'd imagine this is similar to what your trying to achieve, just a few extra folders and permissions to set? Let me know if this is what your looking? if you need a help to piece it all together let me know.

    Cheers Matt :)

    Friday, June 25, 2010 11:24 PM
  • Hi Joe

    Here is an example for you, i've added more functionality, logging and error checking. You may wish to tweak the icacls commands to ensure the NTFS permissions meet your requirements.

    Copy the code below as "CreateHomeFolders.vbs" and save it to a directory EG the "C:\Scripts\CreateHomeFolders.vbs" on the server which will host the user's homefolders. Create a file named "UserNames.txt" with the "C:\Scripts" folder that containing the users logon name (sAMAccountName) to create home directorys for. I'd suggest you add one user to the text file and test it first to ensure the permissions meet your requirements. I tested this on VM (Server 2008 DC) and worked fine so let me know if you have any issues.

    One last recommendation...I'd strongly advise you change the group you assign full control permissions to from "Domain Admins" to another group. I'd suggest creating a seperate AD global security group EG "Homedrive Data Administrators" and assign full control to that group instead of "Domain Admins". This will ensure there is a seperation of administrative responsibility between administrators who actually require administrative privellages in AD as oppossed to those who just need to manage data and NTFS permissions otherwise you may find yourself having to add users to the domain admins group just so they can manage data!

    Hope this helps

    Cheers Matt :)

    '-------------------------------------------------------------------------------------------------
    'Script Name : CreateHomeFolders.vbs  
    'Author   : Matthew Beattie
    'Created   : 26/06/10  
    'Description : This script reads a text file from the scripts working directory named "UserNames.txt"
    '      : The text file contains a list of Active Directory user names to creates a home folder 
    '      : structure for and assigns NTFS permissions using the icacls.exe utility.
    '      : All results are logged within the scripts directory.
    '      : 
    '      : Creates a folder for each user with the following NTFS Permissions on each folder
    '      : 
    '      : %Username% <- (Domain Users have List\Traverse folder permissions. Domain Admins have full control)
    '      :  Public  <- (Domain Admins Full Control, Domain Users have read only. User has modify access on this folder)
    '      :  Private <- (Domain Admins Full Control, User has Modify Access)
    '      :  DropZone <- (Domain Admins Full Control, User has Modify. Domain Users have write only acces)
    '-------------------------------------------------------------------------------------------------
    'Initialization Section  
    '-------------------------------------------------------------------------------------------------
    Option Explicit  
    Const ForReading  = 1  
    Const ForWriting  = 2  
    Const ForAppending = 8  
    Dim objFSO, wshShell, wshNetwork  
    Dim scriptBaseName, scriptPath, scriptLogPath
    On Error Resume Next 
      Set objFSO   = CreateObject("Scripting.FileSystemObject")   
      Set wshNetwork = Wscript.CreateObject("Wscript.Network")  
      Set wshShell  = CreateObject("Wscript.Shell")  
      scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)  
      scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path  
      scriptLogPath  = scriptPath & "\" & scriptBaseName 
      If Err.Number <> 0 Then
       MsgBox "An Unexpected Error Occurred creating global variables", vbCritical 
       Wscript.Quit  
      End If
    On Error Goto 0
    '-------------------------------------------------------------------------------------------------
    'Main Processing Section  
    '-------------------------------------------------------------------------------------------------
    On Error Resume Next
      PromptStart
      ProcessScript  
      If Err.Number <> 0 Then
       PromptError "Processing Script"
       Wscript.Quit
      End If
      PromptEnd
    On Error Goto 0  
    '-------------------------------------------------------------------------------------------------
    'Functions Processing Section
    '-------------------------------------------------------------------------------------------------
    'Name    : ProcessScript -> Primary Function that controls all other script processing.
    'Parameters : None     ->
    'Return   : None     ->
    '-------------------------------------------------------------------------------------------------
    Function ProcessScript
      Dim fileSpec, folderSpec, folderNames, userNames
      fileSpec  = scriptPath & "\UserNames.txt"
      folderSpec = "C:\Data\Users"
      folderNames = Array("Public","Private","DropZone")
      '----------------------------------------------------------------------------------------------
      'Ensure the Script input file exists.
      '----------------------------------------------------------------------------------------------
      If Not objFSO.FileExists(fileSpec) Then
       MsgBox DQ(fileSpec) & " does not exist!", vbCritical, scriptBaseName
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Read the list of user's from the script's input file.
      '----------------------------------------------------------------------------------------------
      If Not GetScriptInput(userNames, fileSpec) Then
       MsgBox "Failed to read the file " & DQ(fileSpec), vbCritical, scriptBaseName
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Create the folder structure and set the NTFS permissions for each user and sub folders.
      '----------------------------------------------------------------------------------------------
      If Not CreateHomeFolders(userNames, folderNames, folderSpec) Then
       Exit Function
      End If
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : CreateHomeFolders -> Primary Function that controls all other script processing.
    'Parameters : userNames     -> Array containing usernames to create homefolders for.
    '      : folderNames    -> Array containing folder names of sub folders to create.
    '      : folderSpec    -> String containing the root folder to create the homefolders in.
    'Return   : CreateHomeFolders -> Returns True if all homefolders were created otherwise False.
    '-------------------------------------------------------------------------------------------------
    Function CreateHomeFolders(userNames, folderNames, folderSpec)
      Dim commands, command, timeOut, errorCount
      Dim userName, folderName, folderPath
      CreateHomeFolders = False
      timeOut      = 10
      errorCount    = 0
      '----------------------------------------------------------------------------------------------
      'Ensure the usernames and folderNames parameters are valid arrays
      '----------------------------------------------------------------------------------------------
      If Not IsArray(userNames) And Not IsArray(folderNames) Then
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Ensure the root folder to create the user's home directories in exists.
      '----------------------------------------------------------------------------------------------
      If Not objFSO.FolderExists(folderSpec) Then
       If Not CreateFolder(folderSpec) Then
         Exit Function
       End If
      End If
      '----------------------------------------------------------------------------------------------
      'Create Each users home directory folder and set their NTFS Permissions.
      '----------------------------------------------------------------------------------------------
      For Each userName In userNames
       folderPath = folderSpec & "\" & userName
       Do
         '----------------------------------------------------------------------------------------
         'Create the user's root home folder
         '----------------------------------------------------------------------------------------
         If Not CreateFolder(folderSpec & "\" & userName) Then
          errorCount = errorCount + 1
          Exit Do
         End If
         LogMessage 0, "Successfully Created folder " & DQ(folderPath)
         '----------------------------------------------------------------------------------------
         'Create the sub folders within the users home directory and set the NTFS permissions.
         '----------------------------------------------------------------------------------------
         For Each folderName In folderNames
          folderPath = folderSpec & "\" & userName & "\" & folderName
          '-------------------------------------------------------------------------------------
          'Select the command to execute to set the NTFS permissions for each sub folder.
          '-------------------------------------------------------------------------------------
          Select Case folderName
            Case "Public"
             commands = Array("icacls.exe " & DQ(folderPath) & " /Inheritance:R", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Admins") & ":(CI)(OI)F", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Users") & ":(CI)(OI)RX", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ(userName)    & ":(CI)(OI)M")
            Case "Private"
             commands = Array("icacls.exe " & DQ(folderPath) & " /Inheritance:R", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Admins") & ":(CI)(OI)F", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ(userName)    & ":(CI)(OI)M")
            Case "DropZone"
             commands = Array("icacls.exe " & DQ(folderPath) & " /Inheritance:R", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Admins") & ":(CI)(OI)F", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ("Domain Users") & ":(CI)(OI)W", _
                      "icacls.exe " & DQ(folderPath) & " /Grant " & DQ(userName)    & ":(CI)(OI)M")
            Case Else
             Exit For
          End Select
          '-------------------------------------------------------------------------------------
          'Create Each sub folder.
          '-------------------------------------------------------------------------------------
          Do
            If Not CreateFolder(folderPath) Then
             errorCount = errorCount + 1
             Exit Do
            End If
            LogMessage 0, "Successfully Created folder " & DQ(folderPath)
            '----------------------------------------------------------------------------------
            'Execute each command to set the NTFS permissions on the sub folder.
            '----------------------------------------------------------------------------------
            For Each command In commands
             Do
               If Not SetACL(folderPath, command, timeOut) Then
                errorCount = errorCount + 1
                Exit Do
               End If
               LogMessage 0, "Successfully processed command: " & command
             Loop Until True
            Next
          Loop Until True
         Next
       Loop Until True
      Next
      '----------------------------------------------------------------------------------------------
      'Ensure the Function returns False if any errors have occurred.
      '----------------------------------------------------------------------------------------------
      If errorCount <> 0 Then
       Exit Function
      End If
      CreateHomeFolders = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : SetACL   -> Recursive Function to Create a directory structure or single folder.
    'Parameters : folderPath -> String containing the Path of folder to configure the access control list on.
    '      : command  -> String containing the icacls command used to configure the access control list.
    '      : timeOut  -> Integer containing the number of seconds to wait for the command to complete before exiting.
    'Return   : SetACL   -> Returns True if ACL was successfully configured otherwise returns False.
    '-------------------------------------------------------------------------------------------------
    Function SetACL(folderPath, command, timeOut)
      Dim results, errors, errorCount, i
      SetAcl   = False
      errorCount = 0
      '----------------------------------------------------------------------------------------------
      'Process the icacls command to set the NTFS permissions.
      '----------------------------------------------------------------------------------------------
      If Not RunCommand(results, command, timeOut) Then
       Exit Function
      End If
      '----------------------------------------------------------------------------------------------
      'Process the output results of the icacls command.
      '----------------------------------------------------------------------------------------------
      For i = 0 To UBound(results)
       Do
         '----------------------------------------------------------------------------------------
         'Search for the semi colon character in each line of the icacls command output.
         '----------------------------------------------------------------------------------------
         If InStr(1, results(i), ";", vbTextCompare) <> 0 Then
          On Error Resume Next
            '----------------------------------------------------------------------------------
            'Find the number of errors in the icalcs command output.
            '----------------------------------------------------------------------------------
            errors = CInt(Trim(Replace(Replace(Split(results(i), ";")(1), "Failed processing", ""), "files", "")))
            If Err.Number <> 0 Then
             LogError 1, "Splitting string " & DQ(results(i))
             errorCount = errorCount + 1
             Exit Do
            End If
          On Error Goto 0
          '-------------------------------------------------------------------------------------
          'Ensure the Function returns False if the icacls command output contained any errors.
          '-------------------------------------------------------------------------------------
          If errors <> 0 Then
            Exit Function
          End If
         End If
       Loop Until True
      Next
      If errorCount <> 0 Then
       Exit Function
      End If
      SetAcl = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : CreateFolder -> Recursive Function to Create a directory structure or single folder.
    'Parameters : folderSpec  -> Path of folder\folders to create.
    'Return   : CreateFolder -> Returns True if the directory structure was successfully created otherwise False.
    '-------------------------------------------------------------------------------------------------
    Function CreateFolder(folderSpec)
      CreateFolder = False
      If Not objFSO.FolderExists(folderSpec) Then
       If InStrRev(folderSpec, "\") <> 0 Then
         If Not CreateFolder(Left(folderSpec, InStrRev(folderSpec, "\") - 1)) Then
          Exit Function
         End If
       End If
       On Error Resume Next
         objFSO.CreateFolder folderSpec
         If Err.Number <> 0 Then
          LogMessage 1, "Creating folder " & DQ(folderSpec)
          Exit Function
         End If
       On Error Goto 0
      End If
      CreateFolder = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : RunCommand -> Executes a command.
    'Parameters : output   -> Input/Output : An array containing the Output resulting from the command.
    '      : command  -> String containting the command to execute.
    '      : timeout  -> Integer containing the Timeout value in seconds to wait for the command to complete.
    'Return   : RunCommand -> Returns True if command was successful otherwise returns False.
    '-------------------------------------------------------------------------------------------------
    Function RunCommand(output, command, timeout)
      Dim objExec, waited
      RunCommand = False
      output   = ""
      waited   = 0
      '----------------------------------------------------------------------------------------------
      'Execute the command.
      '----------------------------------------------------------------------------------------------
      On Error Resume Next
       Set objExec = wshShell.Exec(command)
       If Err.Number <> 0 Then
         LogMessage 1, "Executing command " & DQ(command)
         Exit Function
       End If
      On Error Goto 0
      '----------------------------------------------------------------------------------------------
      'Wait until the command has completed or the the timout is exceeded.
      '----------------------------------------------------------------------------------------------
      Do Until objExec.status = 1 Or (waited >= timeout And timeout > 0)
       output = output & objExec.StdOut.ReadAll
       Wscript.Sleep 100
       waited = waited + 100
      Loop
      '----------------------------------------------------------------------------------------------
      'Remove empty lines from the output string before converting to an Array.
      '----------------------------------------------------------------------------------------------
      Do While InStr(output, vbNewLine & vbNewLine) <> 0
       output = Replace(output, vbNewLine & vbNewLine, vbNewLine)
      Loop
      If Left(output, 1) = vbNewLine Then
       output = Mid(output, 2)
      End If
      If Right(output, 1) = vbNewLine Then
       output = Left(output, Len(output) -1)
      End If
      output = ToArray(output, vbNewLine)
      RunCommand = True
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : DQ     -> Place double quotes around a string and replace double quotes
    '      :       -> within the string with pairs of double quotes.
    'Parameters : stringValue -> String value to be double quoted
    'Return   : DQ     -> Double quoted string.
    '-------------------------------------------------------------------------------------------------
    Function DQ(ByVal stringValue)
      If stringValue <> "" Then
       DQ = """" & Replace(stringValue, """", """""") & """"
      Else
       DQ = """"""
      End If
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : ToArray  -> Checks the list value to determine if the Array is Empty.
    'Parameters : list   -> String value to check for Array conversion.
    'Parameters : delimiter -> value to use to split the string into an Array.
    'Return   :      -> Returns the an Empty Array if the list value if blank
    '      :      -> else splits the string value into an Array.
    '-------------------------------------------------------------------------------------------------
    Function ToArray(list, delimiter)
      If list = "" Then
       ToArray = Array
      Else
       ToArray = Split(list, delimiter)
      End If
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : NewDictionary -> Creates a new dictionary object.
    'Parameters : None     ->
    'Return   : NewDictionary -> Returns a dictionary object.
    '-------------------------------------------------------------------------------------------------
    Function NewDictionary
      Dim dict
      Set dict     = CreateObject("scripting.Dictionary")
      dict.CompareMode = vbTextCompare
      Set NewDictionary = dict
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : GetScriptInput -> Reads a text file to be used as the scripts input into a dictionary object.
    '      :        -> Each line of the text file is added to a Dictionary object. Duplicate lines are ignored.
    'Parameters : results    -> Input/Output : An array of unique items read from the text file.
    '      : fileSpec    -> String containing the folder path and file name of the script input file.
    'Return   : GetScriptInput -> Returns false if the user input file is invalid else returns true.
    '-------------------------------------------------------------------------------------------------
    Function GetScriptInput(results, fileSpec)
      Dim objTextFile, objDict, line
      GetScriptInput = False
      Set objDict  = NewDictionary
      On Error Resume Next
       Set objTextFile = objFSO.OpenTextFile(fileSpec, ForReading)
       If Err.Number <> 0 Then
         BuildMessage 1, "Opening Text File " & DQ(fileSpec)
         Exit Function
       End If
       Do Until objTextFile.AtEndOfStream
         line = objTextFile.Readline
         If Err.Number <> 0 Then
          BuildMessage 1, "Reading a line from within the file " & DQ(fileSpec)
          Exit Function
         End If
         If Not objDict.Exists(line) Then
          objDict(objDict.Count) = line
         End If
       Loop
      On Error Goto 0
      GetScriptInput = True
      results    = objDict.Items
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : LogMessage -> Parses a message to the log file based on the messageType.  
    'Parameters : messageType -> Integer representing the messageType.
    '      :       -> 0 = message    (writes to a ".log" file)
    '      :       -> 1 = error,    (writes to a ".err" file including information relating to the error object.)
    '      :       -> 2 = error message (writes to a ".err" file without information relating to the error object.)
    '      : message   -> String containing the message to write to the log file.
    'Return   : None    -> 
    '-------------------------------------------------------------------------------------------------
    Function LogMessage(messageType, message)
      Dim logType
      Select Case messageType
       Case 0
         logType = "log"
       Case 1
         logType = "err"
         message = "Error " & Err.Number & " (Hex " & Hex(Err.Number) & ") " & message & ". " & Err.Description
       Case Else
         LogType = "err"
      End Select
      If Not LogToFile(scriptLogPath & "." & logType, message) Then 
       Exit Function 
      End If
    End Function 
    '-------------------------------------------------------------------------------------------------
    'Name    : LogToFile -> Write a message into the user's network log file.  
    'Parameters : LogSpec  -> String containing the Folder path, file name and extension of the log file to write to.  
    '      : message  -> String containing the Message to be logged.  
    'Return   : LogToFile -> Returns True if successful otherwise returns false.  
    '-------------------------------------------------------------------------------------------------
    Function LogToFile(logSpec, message)  
      LogToFile = False 
      On Error Resume Next 
       With objFSO.OpenTextFile(logSpec, ForAppending, True)  
         .WriteLine Date & " " & Time & " " & message
         .Close  
       End With 
       If Err.Number <> 0 Then 
         Exit Function 
       End If 
      On Error Goto 0  
      LogToFile = True 
    End Function 
    '-------------------------------------------------------------------------------------------------
    'Name    : PromptStart -> Prompt when script starts.
    'Parameters : None    ->
    'Return   : None    ->
    '-------------------------------------------------------------------------------------------------
    Function PromptStart
      MsgBox "Now processing the " & DQ(Wscript.ScriptName) & " script.", vbInformation, scriptBaseName
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : PromptEnd -> Prompts when script has completed.
    'Parameters : None   ->
    'Return   : None   ->
    '-------------------------------------------------------------------------------------------------
    Function PromptEnd
      MsgBox "The " & DQ(Wscript.ScriptName) & " script has completed successfully.", vbInformation, scriptBaseName
    End Function
    '-------------------------------------------------------------------------------------------------
    'Name    : PromptError -> Prompts when an unexpected script error occurs.
    'Parameters : None    ->
    'Return   : None    ->
    '-------------------------------------------------------------------------------------------------
    Function PromptError
      MsgBox "Error " & Err.Number & " (Hex " & Hex(Err.Number) & "). " & Err.Description, vbCritical, scriptBaseName
    End Function
    '-------------------------------------------------------------------------------------------------
    Saturday, June 26, 2010 6:28 AM
  • Matthew,  this script is fantstic! Can you please send me your email and do you like amazon? I would like to send you a gift. joe@mplspc.com is my email address.  You have saved me HOURS of time thank you !!
    Saturday, June 26, 2010 12:43 PM
  • Matthew,  apologies for not responding to your suggestion with regards to the domain admins having full rights.  I do have three sub admin groups for each site but did not want to make this question harder than needed.  Thanks again!

    Saturday, June 26, 2010 12:47 PM