Dim objWMI, objSecSettings, objSD, objACE
Dim strShareServer, strShareName, strShareTarget, xRes
Const FULL_ACCESS = 2032127

strShareTarget = "D:\Folder"
strShareServer = "fileserver"
strShareName = "Имя_ресурса"
On Error Resume Next
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strShareServer & "\root\CIMV2")
If Err.Number = 0 Then
    xRes = objWMI.Get("Win32_Share").Create(strShareTarget, strShareName, 0)
    If xRes = 0 Then
        Set objSecSettings = objWMI.Get("Win32_LogicalShareSecuritySetting.Name='" & strShareName & "'")
        If objSecSettings.GetSecurityDescriptor(objSD) = 0 Then
            If Not IsNull(objSD.DACL) Then
                For Each objACE In objSD.DACL
                    objACE.AccessMask = FULL_ACCESS
                Next
                Set objACE = Nothing
                xRes = objSecSettings.SetSecurityDescriptor(objSD)
                Select Case xRes
                    Case 0: xRes = "Успешное завершение."
                    Case 2: xRes = "Отсутствует доступ к необходимой информации."
                    Case 9: xRes = "Для выполнения операции недостаточно полномочий."
                    Case 21: xRes = "Заданы недопустимые значения параметров."
                    Case Else: xRes = "Неизвестная ошибка с кодом: " & xRes
                End Select
            Else
                xRes = "Список управления доступом к ресурсу " & UCase(strShareName) & " пуст."
            End If
        Else
            xRes = "Не удалось прочитать дескриптор безопасности ресурса " & UCase(strShareName)
        End If
        Set objSD = Nothing
        Set objSecSettings = Nothing
    Else
        xRes = "Ошибка " & xRes & " при создании ресурса общего доступа " & UCase(strShareName)
    End If
    WScript.Echo xRes
Else
    WScript.Echo "Ошибка " & CStr(Err.Number) & vbNewLine & Err.Description
    Err.Clear
End If
Set objWMI = Nothing
WScript.Quit 0

'====Настройки скрипта========
strServerName = "server01"
strFolderPath = "\\server01\D$\Share"
srtRemoteFolderPath = "D:\Share\"
'=============================

strFolderName = Trim(InputBox("Введите название папки", "Создание новой папки на сервере"))

' Создаём папку на сервере
Set objFSO   = WScript.CreateObject("Scripting.FileSystemObject")
strFullFolderPath = objFSO.BuildPath(strFolderPath, strFolderName)
If objFSO.FolderExists(strFullFolderPath) Then
 WScript.Echo "Папка: '"& strFolderName &"' уже существует." & vbNewLine & _
                     "Скрипт завершает свою работу."
    Wscript.Quit 0
Else
    objFSO.CreateFolder strFullFolderPath
End If

'Расшариваем папку в правами Everyone = Full Access
Const FULL_ACCESS = 2032127
Const ACCESS_ALLOWED = 0

Set objWMI = GetObject("winmgmts:\\" & strServerName & "\root\cimv2")
      Set objTrustee = objWMI.Get("Win32_Trustee").SpawnInstance_
      objTrustee.Properties_.Item("SID") = Array(1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0)
      Set objACE = objWMI.Get("Win32_Ace").SpawnInstance_
      objACE.AccessMask = FULL_ACCESS
      objACE.AceFlags = 3
      objACE.AceType = ACCESS_ALLOWED
      objACE.Trustee = objTrustee
      Set objSD = objWMI.Get("Win32_SecurityDescriptor").SpawnInstance_()
      objSD.DACL = Array(objACE)
      Set objShare = objWMI.Get("Win32_Share")
      intResult = objShare.Create(srtRemoteFolderPath & strFolderName, strFolderName, 0, Null, Null, Null, objSD)

WScript.Echo "Папка: '"& strFolderName &"' успешно создана и расшарена"
Wscript.Quit 0