VBS: Создание папки пользователя и предоставление прав

Необходимо было автоматизировать создание папки пользователя на сетевом ресурсе и  предоставить права на запись. Ниже предоставлен скрипт создания папки пользователя на сетевом каталоге и предоставление прав ни  запись.

Его возможности:

1)Создает каталог пользователя  и предоставляет доступ. Если папка уже есть, то ничего не делается, только сообщени.

2)Ввод имени пользователя в формате domain\user1 или user1, так же если есть домен третьего уровня, то можно задать указать и его(это одна из условий и было)


Dim strLogin
dim strPath
strPath ="\\testsrv\foder"         ' путь, где создается папка
strPathLocal ="Z:\folder"                 'локальный путь папки на сервере, где создается папка
strComputer="testsrv.dom.net"     ' имя сервера
strDomain="dom"     ' домен по умолчанию

strLogin = Inputbox("Имя учетной записи","Создание каталога")
if strlogin ="" then  
 WScript.Quit 0
end if
'получение имени домена из введеной учетки  в противном случае домен strDomain
for i=1 to len (strLogin)
 if mid(strLogin,i,1)= "\"  then
  strDomain=mid(strLogin,1,i-1)
  strLogin=mid(strLogin,i+1,len (strLogin))

  exit for
 end if
next

Set FSO   = WScript.CreateObject("Scripting.FileSystemObject")
strPath = FSO.BuildPath(strpath,strlogin) 'создаем окончательный путь
' создание папки и проверка на существавание её
If FSO.FolderExists(strpath) Then
 WScript.Echo "Папка: '"& strpath &"' уже существует.Выход."
    Wscript.Quit 0
Else
    FSO.CreateFolder strpath
End If

strPathLocal=strPathLocal+"\"+strLogin
  xResult = Set_RWEAccess(strDomain, strComputer, strLogin, strPathLocal) ' процедура предоставления прав.
        If IsNumeric(xResult) Then xResult = CStr(xResult)
        Select Case xResult
            Case "-3": Wscript.Echo "Не удалось настроить параметры доступа существующей записи " & UCase(strDomain & "\" & strLogin)
            Case "-2": Wscript.Echo "Не найдена учётная запись объекта " & UCase(strDomain & "\" & strLogin)
            'Case "-1": Wscript.Echo "Не удалось отключить наследование безопасности у папки " & UCase(strPath)
            Case "0": Wscript.Echo "Успешное завершение."
            Case "2": Wscript.Echo "Доступ запрещён."
            Case "8": Wscript.Echo "Неизвестная ошибка."
            Case "5", "9": Wscript.Echo "Для выполнения операции недостаточно полномочий."
            Case "21": Wscript.Echo "Заданы недопустимые значения параметров."
            Case Else: WScript.Echo xResult
        end select

'Удаление папки, если ошибка с правами
if xresult<>0 then FSO.DeleteFolder strpath


' функция предоставления доступа , стащено c изменениями с серого форума http://forum.script-'coding.com/
Function Set_RWEAccess(strDom, strComp, strSAN, strDir)
Dim objWMI, objSecSettings, objSD, objACE
Dim xRes, arrACE, objCollection, objItem, strSID
Dim objSID, objTrustee, objNewACE
Dim blnHasACE, i
Const SE_DACL_PROTECTED = 4096
Const ACCESS_ALLOWED_ACE_TYPE = 0
Const READ_WRITE_EXECUTE = 1245631 '1180095
'маски доступа нашел кое как FullAccessMask = 2032127, ModifyAccessMask = 1245631, WriteAccessMask = 1180095
'                  2032127 {$AccessMask = "FullControl"}
'                  1179785 {$AccessMask = "Read"}
'                  1180063 {$AccessMask = "Read, Write"}
'                  1179817 {$AccessMask = "ReadAndExecute"}
'                 -1610612736 {$AccessMask = "ReadAndExecuteExtended"}
'                  1245631 {$AccessMask = "ReadAndExecute, Modify, Write"}
'                  1180095 {$AccessMask = "ReadAndExecute, Write"}
'                  268435456 {$AccessMask = "FullControl (Sub Only)"}
Const OBJECT_INHERIT_ACE = 1
Const CONTAINER_INHERIT_ACE = 2
Const INHERITED_ACE = 16
On Error Resume Next
xRes = 0
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComp & "\root\cimv2")
Set objWMI1 = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") 'пришлось делать с запросы к AD с локального компа.
If Err.Number = 0 Then
    Set objSecSettings = objWMI.Get("Win32_LogicalFileSecuritySetting.Path='" & strDir & "'")

    If Err.Number = 0 Then
        If objSecSettings.GetSecurityDescriptor(objSD) = 0 Then
            If Not IsNull(objSD.DACL) Then
                REM If Not CBool(objSD.ControlFlags And SE_DACL_PROTECTED) Then
                    REM objSD.ControlFlags = objSD.ControlFlags + SE_DACL_PROTECTED
                    REM xRes = objSecSettings.SetSecurityDescriptor(objSD)
                REM End If
                rem If xRes = 0 Then
                    If Len(strDom) > 0 Then
         ' msgbox "SELECT SID FROM Win32_Account WHERE Domain='" & strDom & "' AND Name='" & strSAN & "'"            
     Set objCollection = objWMI1.ExecQuery("SELECT SID FROM Win32_Account WHERE Domain='" & strDom & "' AND Name='" & strSAN & "'")         
                    Else
                        Set objCollection = objWMI1.ExecQuery("SELECT SID FROM Win32_Account WHERE Name='" & strSAN & "'")
                    End If
                   ' msgbox objCollection.count   
                    If objCollection.Count > 0 Then
                        For Each objItem In objCollection
                            strSID = UCase(objItem.SID)
                        Next
                        Set objItem = Nothing
                        For Each objACE In objSD.DACL
   
                            If UCase(objACE.Trustee.SIDString) = strSID Then
                                blnHasACE = True
                                objACE.AceType = ACCESS_ALLOWED_ACE_TYPE
                                objACE.AccessMask = READ_WRITE_EXECUTE
                            End If
                        Next
                        xRes = objSecSettings.SetSecurityDescriptor(objSD)
                        If xRes = 0 Then
                            If Not blnHasACE Then
                                arrACE = objSD.DACL
                                Set objSID = objWMI1.Get("Win32_SID.SID='" & strSID & "'")
                                Set objTrustee = objWMI1.Get("Win32_Trustee").Spawninstance_()
                                objTrustee.Domain = strDom
                                objTrustee.Name = strSAN
                                objTrustee.SID = objSID.BinaryRepresentation
                                objTrustee.SidLength = objSID.SidLength
                                objTrustee.SIDString = strSID
                                Set objSID = Nothing
                                Set objNewACE = objWMI1.Get("Win32_Ace").Spawninstance_()
                                objNewACE.AceType  = ACCESS_ALLOWED_ACE_TYPE
                                objNewACE.AceFlags = OBJECT_INHERIT_ACE + CONTAINER_INHERIT_ACE
                                objNewACE.AccessMask = READ_WRITE_EXECUTE
                                objNewACE.Trustee = objTrustee
                                Set objTrustee = Nothing
                                i = UBound(arrACE) + 1
                                ReDim Preserve arrACE(i)
                                Set arrACE(i) = objNewACE
                                objSD.DACL = arrACE
                                Set objNewACE = Nothing
                                Erase arrACE
                                xRes = objSecSettings.SetSecurityDescriptor(objSD)
                            End If
                        Else
                            xRes = -3
                        End If
                    Else
                        xRes = -2
                    End If
                    Set objCollection = Nothing
                REM Else
                    REM xRes = -1
                REM End If
            Else
                xRes = "Список управления доступом (ACL) к заданному объекту пуст."
            End If
        Else
            xRes = "Не удалось прочитать дескриптор безопасности объекта."
        End If
        Set objSD = Nothing
        Set objSecSettings = Nothing
    Else
        xRes = "Ошибка " & CStr(Err.Number) & vbNewLine & Err.Description
        Err.Clear
    End If
Else
    xRes = "Ошибка " & CStr(Err.Number) & vbNewLine & Err.Description
    Err.Clear
End If
Set objWMI = Nothing
On Error GoTo 0
Set_RWEAccess = xRes
End Function

Скрипт полностью работающий.