Код:
'Пояснения:
'1) предполагается, что сценарий должен запускаться на компьютерах, работающих под управлением ОС серверного типа, русифицированных;
'2) Владелец пользовательских папок назначается системой автоматически (пользователь, в контексте безопасности которого запущен сценарий);
'3) Создаётся и открывается для общего доступа одна ("родительская") папка, в которой создаются папки для пользователей;
'4) По завершении создания пользовательских папок "родительская" папка открывается для общего доступа с SMB-маской "всем всё разрешено";
'5) Имя новоявленной "шаре" назначается такое же, как и у её базовой папки. Если же "шара" с таким именем уже существует, то к имени базовой папки добавляется строка с текущей датой;
'6) В DACL "родительской" папки добавляется (в дополнение к унаследованным) запись для "учётки" Пользователи домена с полномочиями чтение + запись + выполнение;
'7) В DACL пользовательских папок добавляется (в дополнение к унаследованным) запись для "учётки" соответствующего пользователя с полномочиями чтение + запись + выполнение + удаление подпапок и файлов;
'8) Пользовательские папки, соответствующие отключенным "учёткам", не создаются;
'9) Журнал работы создаётся в той же папке, где расположен и файл сценария.
Dim objWsNet, objGroup, objUser
Dim strDomain, strUser, strExcludeUsers, arrBaseGroups
Dim objFS, objFile, strErrLog, strErrors
Dim strPath, xResult, strTranslator, blnContinue, strTemp, arrTemp, i
Dim objWMI, objCollection, objItem
strPath = "X:\Folder"
strExcludeUsers = "user1;user2;user3;" 'список исключения для заданных групп, (если требуется)
strErrLog = "Create_Folders_Errors.log"
arrBaseGroups = Array("Группа1", "Группа2")
Set objFS = CreateObject("Scripting.FileSystemObject")
strTranslator = objFS.GetBaseName(WScript.FullName)
If StrComp(strTranslator, "cscript", vbTextCompare) = 0 Then
Set objWsNet = CreateObject("WScript.Network")
strDomain = objWsNet.UserDomain
Set objWsNet = Nothing
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
Set objCollection = objWMI.ExecQuery("SELECT Caption FROM Win32_OperatingSystem")
For Each objItem In objCollection
strTemp = objItem.Caption
Next
Set objItem = Nothing
Set objCollection = Nothing
If InStr(1, strTemp, "server", vbTextCompare) = 0 Then
WScript.Echo "Сценарий предназначен для использования на компьютере с серверной ОС." & _
vbNewLine & "Продолжение работы невозможно."
Else
If objFS.FolderExists(strPath) Then
WScript.Echo "Папка " & UCase(strPath) & " уже существует." & _
vbNewLine & "Продолжение работы невозможно."
Else
On Error Resume Next
objFS.CreateFolder strPath
If Err.Number = 0 Then
xResult = Set_ACL(strPath, "Пользователи домена", strDomain)
If IsNumeric(xResult) Then
strErrLog = objFS.BuildPath(objFS.GetParentFolderName(WScript.ScriptFullName), strErrLog)
For i = 0 To UBound(arrBaseGroups)
strErrors = vbNullString
WScript.Echo "======" & vbNewLine & UCase(arrBaseGroups(i)) & vbNewLine & "======"
Set objGroup = GetObject("WinNT://" & strDomain & "/" & arrBaseGroups(i) & ",group")
If Err.Number = 0 Then
For Each objUser In objGroup.Members
strUser = objUser.Name
If Err.Number = 0 Then
If Not objUser.AccountDisabled Then
If InStr(1, strExcludeUsers, strUser & ";", vbTextCompare) = 0 Then
If Not objFS.FolderExists(strPath & "\" & strUser) Then
objFS.CreateFolder strPath & "\" & strUser
If Err.Number <> 0 Then
WScript.Echo strUser & " -> ошибка " & Err.Number & " при попытке создать папку" & vbNewLine & Err.Description
strErrors = strErrors & strUser & " -> ошибка " & Err.Number & " при попытке создать папку" & vbNewLine & Err.Description & vbNewLine
Err.Clear
blnContinue = False
End If
End If
If blnContinue Then
xResult = Set_ACL(strPath & "\" & strUser, strUser, strDomain)
If IsNumeric(xResult) Then
WScript.Echo strUser & " -> успешное завершение"
Else
WScript.Echo strUser & " -> " & xResult
strErrors = strErrors & UCase(strUser) & vbNewLine & xResult & vbNewLine & "------" & vbNewLine
End If
Else
blnContinue = True
End If
Else
WScript.Echo strUser & " -> учётная запись пропущена"
End If
Else
WScript.Echo strUser & " -> учётная запись отключена"
'strErrors = strErrors & strUser & " -> учётная запись отключена" & vbNewLine
End If
Else
WScript.Echo strUser & " -> ошибка " & Err.Number & " при попытке привяки к учётной записи" & vbNewLine & Err.Description
strErrors = strErrors & strUser & " -> ошибка " & Err.Number & " при попытке привяки к учётной записи" & vbNewLine & Err.Description & vbNewLine
Err.Clear
End If
Next
Else
WScript.Echo "Ошибка " & Err.Number & " при попытке привяки к объекту группы " & UCase(arrBaseGroups(i)) & vbNewLine & Err.Description
strErrors = strErrors & "Ошибка " & Err.Number & " при попытке привяки к объекту группы " & UCase(arrBaseGroups(i)) & vbNewLine & Err.Description & vbNewLine
Err.Clear
End If
Set objGroup = Nothing
If Len(strErrors) > 0 Then
Set objFile = objFS.OpenTextFile(strErrLog, 8, True)
objFile.Write Now & vbNewLine & strErrors
objFile.Close
End If
Next
Set objUser = Nothing
arrTemp = Split(strPath, "\")
If Len(arrTemp(UBound(arrTemp))) > 0 Then
strTemp = arrTemp(UBound(arrTemp))
Else
strTemp = arrTemp(UBound(arrTemp) - 1)
End If
xResult = Create_Share_To_All(strPath, strTemp)
If Not IsNumeric(xResult) Then
WScript.Echo xResult
strErrors = strErrors & xResult & vbNewLine
End If
If Len(strErrors) > 0 Then
Set objFile = objFS.OpenTextFile(strErrLog, 8, True)
objFile.Write Now & vbNewLine & strErrors
objFile.Close
End If
Set objFile = Nothing
If objFS.FileExists(strErrLog) Then
WScript.Echo "Работа сценария завершена с ошибками." & vbNewLine & "Файл журнала: " & UCase(strErrLog)
Else
WScript.Echo "Работа сценария завершена без ошибок."
End If
Else
WScript.Echo "Не удалось настроить список управления доступом к папке " & UCase(strPath) & vbNewLine & xResult
End If
Else
WScript.Echo "Ошибка " & Err.Number & " при попытке создания целевой папки " & UCase(strPath) & vbNewLine & Err.Description
Err.Clear
End If
On Error GoTo 0
End If
End If
Set objWMI = Nothing
Else
WScript.Echo "Сценарий предназначен для работы в консольном режиме."
End If
Set objFS = Nothing
WScript.Quit 0
'======
Function Set_ACL(strDir, strSAN, strDom)
Dim objWMI, objSecSettings, objSD, objACE
Dim xRes, objCollection, objItem
Dim strSID, objSID, objTrustee
Const ACCESS_ALLOWED_ACE_TYPE = 0
Const OBJECT_INHERIT_ACE = 1
Const CONTAINER_INHERIT_ACE = 2
Const SE_DACL_PROTECTED = 4096
Const ACCESS_TO_USER = 1180159
Const ACCESS_TO_ALL = 1180095
On Error Resume Next
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
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
If Not CBool(objSD.ControlFlags And SE_DACL_PROTECTED) Then
objSD.ControlFlags = objSD.ControlFlags + SE_DACL_PROTECTED
xRes = objSecSettings.SetSecurityDescriptor(objSD)
End If
If xRes = 0 Then
Set objCollection = objWMI.ExecQuery("SELECT SID FROM Win32_Account WHERE Domain='" & strDom & "' AND Name='" & strSAN & "'")
If objCollection.Count > 0 Then
For Each objItem In objCollection
strSID = objItem.SID
Next
Set objItem = Nothing
Set objCollection = Nothing
Set objSID = objWMI.Get("Win32_SID.SID='" & strSID & "'")
Set objTrustee = objWMI.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 objACE = objWMI.Get("Win32_Ace").SpawnInstance_
objACE.AceType = ACCESS_ALLOWED_ACE_TYPE
objACE.AceFlags = OBJECT_INHERIT_ACE + CONTAINER_INHERIT_ACE
If StrComp(strSAN, "Пользователи домена", vbTextCompare) = 0 Then
objACE.AccessMask = ACCESS_TO_ALL
Else
objACE.AccessMask = ACCESS_TO_USER
End If
objACE.Trustee = objTrustee
Set objTrustee = Nothing
objSD.DACL = Array(objACE)
Set objACE = Nothing
If Err.Number = 0 Then
objSD.ControlFlags = objSD.ControlFlags - SE_DACL_PROTECTED
xRes = objSecSettings.SetSecurityDescriptor(objSD)
If xRes <> 0 Then
Select Case xRes
Case "2": xRes = "Не удалось добавить запись " & UCase(strDom & "\" & strSAN) & vbNewLine & "Доступ запрещён."
Case "5", "9": xRes = "Не удалось добавить запись " & UCase(strDom & "\" & strSAN) & vbNewLine & "Для выполнения операции недостаточно полномочий."
Case "21": xRes = "Не удалось добавить запись " & UCase(strDom & "\" & strSAN) & vbNewLine & "Заданы недопустимые значения параметров."
Case Else: xRes = "Не удалось добавить запись " & UCase(strDom & "\" & strSAN) & vbNewLine & "Неизвестная ошибка с кодом " & xRes
End Select
End If
Else
xRes = "Ошибка " & Err.Number & " формирования ACE для " & UCase(strDom & "\" & strSAN) & vbNewLine & Err.Description
Err.Clear
End If
Else
xRes = "Не удалось определить SID учётной записи объекта " & UCase(strDom & "\" & strSAN)
End If
Else
xRes = "Не удалось отключить наследование безопасности для папки " & UCase(strDir)
End If
Else
xRes = "Список управления доступом к папке " & UCase(strDir) & " пуст"
End If
Else
xRes = "Не удалось прочитать дескриптор безопасности папки " & UCase(strDir)
End If
Else
xRes = "Ошибка при обращении к экземпляру класса Win32_LogicalFileSecuritySetting " & Err.Number & vbNewLine & Err.Description
Err.Clear
End If
Else
xRes = "Ошибка при привязке к WMI-пространству (функция Set_ACL) " & Err.Number & vbNewLine & Err.Description
Err.Clear
End If
Set objWMI = Nothing
On Error GoTo 0
Set_ACL = xRes
End Function
'======
Function Create_Share_To_All(strDir, strName)
Dim objWMI, objShare, xRes
Dim objSecSettings, objSD, objSID, objTrustee, objACE
Const strSID = "S-1-1-0"
Const strUser = "Все"
Const ACCESS_ALLOWED_ACE_TYPE = 0
Const OBJECT_INHERIT_ACE = 1
Const CONTAINER_INHERIT_ACE = 2
Const FULL_ACCESS = 2032127
Const SE_OWNER_DEFAULTED = 1
Const SE_GROUP_DEFAULTED = 2
Const SE_DACL_PRESENT = 4
On Error Resume Next
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
If Err.Number = 0 Then
Set objSID = objWMI.Get("Win32_SID.SID='" & strSID & "'")
Set objTrustee = objWMI.Get("Win32_Trustee").SpawnInstance_
objTrustee.Name = strUser
objTrustee.SID = objSID.BinaryRepresentation
objTrustee.SidLength = objSID.SidLength
objTrustee.SIDString = strSID
Set objSID = Nothing
Set objACE = objWMI.Get("Win32_Ace").SpawnInstance_
objACE.AccessMask = FULL_ACCESS
objACE.AceFlags = OBJECT_INHERIT_ACE + CONTAINER_INHERIT_ACE
objACE.AceType = ACCESS_ALLOWED_ACE_TYPE
objACE.Trustee = objTrustee
Set objTrustee = Nothing
If Err.Number = 0 Then
Set objSD = objWMI.Get("Win32_SecurityDescriptor").SpawnInstance_
objSD.ControlFlags = SE_OWNER_DEFAULTED + SE_GROUP_DEFAULTED + SE_DACL_PRESENT
objSD.DACL = Array(objACE)
Set objACE = Nothing
If Err.Number = 0 Then
Set objShare = objWMI.ExecQuery("SELECT * FROM Win32_Share WHERE Type=0 AND Name='" & strName & "'")
If objShare.Count > 0 Then strName = strName & "_" & Date
Set objShare = objWMI.Get("Win32_Share")
xRes = objShare.Create(strDir, strName, 0, , , , objSD)
Set objSD = Nothing
If xRes <> 0 Then
Select Case xRes
Case 2: xRes = "Не удалось открыть папку для общего доступа: недостаточно полномочий."
Case 9: xRes = "Не удалось открыть папку для общего доступа: недопустимое имя " & UCase(strName)
Case 21: xRes = "Не удалось открыть папку для общего доступа: заданы недопустимые значения параметров."
Case 22: xRes = "Не удалось открыть папку для общего доступа: попытка создания дубликата."
Case 23: xRes = "Не удалось открыть папку для общего доступа: переадресованный путь."
Case 24: xRes = "Не удалось открыть папку для общего доступа: не найден путь " & UCase(strDir)
Case Else: xRes = "Не удалось открыть папку для общего доступа: неизвестная ошибка с кодом " & xRes
End Select
Set objShare = Nothing
End If
Else
xRes = "Ошибка формирования дескриптора безопасности (функция Create_Share_To_All) " & Err.Number & vbNewLine & Err.Description
Err.Clear
End If
Else
xRes = "Ошибка формирования ACE (функция Create_Share_To_All) " & Err.Number & vbNewLine & Err.Description
Err.Clear
End If
Else
xRes = "Ошибка WMI-пространству (функция Create_Share_To_All) " & Err.Number & vbNewLine & Err.Description
Err.Clear
End If
Set objWMI = Nothing
On Error GoTo 0
Create_Share_To_All = xRes
End Function
