Exchange 2003 - ExchangeSetPFADRights.vbs

'© Kirill 'kf' Nikolaev, 2011
'Все вопросы по скрипту: E-mail/Live: [email protected]

'Скрипт раздаёт права на управление объектами общих папок в Active Directory.
'Основное предназначение — предоставлять гранулированный доступ различным администраторам к общим папкам в пределах одного дерева общих папок. Удобно выполнять по расписанию для проставления нужных разрешений на новые папки.
'Дополнительно, не забудьте предоставить нужные разрешения администраторам на уровне БД Exchange (кнопка Administrative Rights в св-вах общей папки).

'Папки верхнего ур-ня, на подпапки которых требуется предоставлять доступ, записываются в файл, указанный в переменной strRootFoldersList, по 1 папке на строку в следующем формате:
'Название общей папки;TEST - то есть: 1) без обрамляющих слешей 2) Через разделитель (strInSplitter) указывается ИМЯ_ФАЙЛА_СО_СПИСКОМ_СУБЪЕКТОВ_БЕЗОПАСНОСТИ.
'Субъекты безопасности, которым будет предоставлен доступ к объектам общих папок, указываются в соответствующем файле (ИМЯ_ФАЙЛА_СО_СПИСКОМ_СУБЪЕКТОВ_БЕЗОПАСНОСТИ.txt) по одному на строку без каких либо разделителей и т.п.
'То есть вот так: AD1\Administrators

'Как вы можете видеть, в этом скрипте присутствует обёртка, которая позволяет корректно выполнять его в кластерном окружении по расписанию. Вы можете использовать её в любом скрипте.
'Посмотреть и скачать обёртку отдельно вы можете здесь: http://pastebin.com/8KPpmf6P

strManageComputer = "EXCHANGE-SERVER" 'Имя Exchange-сервера, к которому будем подключаться.
strInFolder = "C:\Scripts\ExchangeSetPFADRights" 'Папка входящих данных. В ней расположены strRootFoldersList и ФАЙЛЫ_СО_СПИСКАМИ_СУБЪЕКТОВ_БЕЗОПАСНОСТИ.txt
strOutFolder = strInFolder 'Папка исходящих данных. В ней расположен strResFile.
strResFile = strOutFolder & "\" & WScript.ScriptName & ".txt"
strRootFoldersList = strInFolder & "\RootFoldersList.txt"
strSplitter = ";" 'Разделитель колонок в логе
strInSplitter = strSplitter 'Разделитель колонок в файлах входящих данных.
strClusResource = "EXCHANGE-SERVER Network Name" 'Кластерный ресурс, на владельце которого будет выполняться скрипт.

Set wshNetwork = WScript.CreateObject("WScript.Network")
strComputerName = wshNetwork.ComputerName

Set objCluster = CreateObject("MSCluster.Cluster")
objCluster.Open strManageComputer

If objCluster.Resources.Item(strClusResource).OwnerNode.Name = strComputerName Then 'Проверяем, что текущий компьютер является владельцем нужного кластерного ресурса.

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ResFile = FSO.OpenTextFile(strResFile, 2, True)

    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strManageComputer & "\ROOT\MicrosoftExchangeV2")
    Set colItems = objWMIService.InstancesOf("Exchange_PublicFolder")

    For Each objItem in colItems
        Set RootFoldersList = FSO.OpenTextFile(strRootFoldersList, 1)
        Do While RootFoldersList.AtEndOfLine <> True
            strLine = RootFoldersList.ReadLine()
            strRootFolderDividerPosition = InStr(strLine, strInSplitter)
            strRootFolderName = Left(strLine, strRootFolderDividerPosition-1)
            strRootFolderPath = "/" & strRootFolderName & "/"
            strRootFolderTrusteeList = strInFolder & "\" & Right(strLine, Len(strLine)-strRootFolderDividerPosition) & ".txt"
            strFolderPath = objItem.Path
            If InStr(strFolderPath, strRootFolderPath) = 1 Then
                strResFileLine = strFolderPath
                strFullWebDAVPath = objItem.FriendlyUrl
                XMLSettingValue = GetXMLSettingValue (strFullWebDAVPath, "671D0102")
                If VarType(XMLSettingValue) = 8209 Then 'Проверяем, mail-enabled-ли папка? На не-mail-enabled дальнейшие действия смысла выполнять нет, да и невозможно это.
                    strFolderGUID = OctetToHexStr(XMLSettingValue)
                    strFolderEncodedGUID = GenerateGUIDForLDAPSearch(strFolderGUID)
                    Set objFolderADObject = GetObject(FindADObject("objectGUID", strFolderEncodedGUID))
                    strFolderMail = objFolderADObject.Get("mail")
                    Set FolderTrusteeList = FSO.OpenTextFile(strRootFolderTrusteeList, 1)
                    Do While FolderTrusteeList.AtEndOfLine <> True
                        strTrustee = FolderTrusteeList.ReadLine()
                        SetFolderADACL objFolderADObject, strTrustee
                        strResFileLine = strResFileLine & strSplitter & strTrustee
                    Loop
                    FolderTrusteeList.Close
                    ResFile.WriteLine strResFileLine
                End If
            End If
        Loop
        RootFoldersList.Close
    Next

    ResFile.Close
End If
'Wscript.Echo WScript.ScriptName & " Done" 'Полезно в интерактивном режиме, но мешает при выполнении по расписанию.

Function SetFolderADACL (objFolderADObject, strTrustee) 'Собственно, назначает разрешения.

    Const ADS_OPTION_SECURITY_MASK = 3 'http://support.microsoft.com/kb/323749
    Const ADS_SECURITY_INFO_DACL = 4 'http://support.microsoft.com/kb/323749
    Const ADS_ACETYPE_ACCESS_ALLOWED = &H0 'The ACE is of the standard ACCESS ALLOWED type, where the ObjectType and InheritedObjectType fields are NULL

    Set objFolderSD = objFolderADObject.Get("ntSecurityDescriptor")
    Set objFolderDACL = objFolderSD.DiscretionaryAcl
    Set objAce = CreateObject("AccessControlEntry")

    objAce.AccessMask = -1 'Full Permission (Allowed)
    objAce.AceType = ADS_ACETYPE_ACCESS_ALLOWED
    objAce.AceFlags = &H2 'This object and subcontainers
    objAce.Trustee = strTrustee

    objFolderDACL.AddAce objAce

    objFolderSD.DiscretionaryAcl = objFolderDACL
    objFolderADObject.Put "ntSecurityDescriptor", objFolderSD
    objFolderADObject.SetOption ADS_OPTION_SECURITY_MASK, ADS_SECURITY_INFO_DACL 'http://support.microsoft.com/kb/323749
    objFolderADObject.SetInfo

End Function

Function GetXMLSettingValue (strFullWebDAVPath, strSetting) 'Получает значение св-ва общей папки по WebDAV.
    Dim strRequest
    Set objXML = CreateObject("msxml2.xmlhttp")
    objXML.Open "PROPFIND", strFullWebDAVPath, FALSE
    objXML.SetRequestHeader "Content-type:", "text/xml"
    objXML.SetRequestHeader "Depth", "0"
    strRequest = "<?xml version='1.0'?>"
    strRequest = strRequest & "<a:propfind xmlns:a='DAV:' xmlns:p='http://schemas.microsoft.com/mapi/proptag/'>"
    strRequest = strRequest & "<a:prop><p:x" & strSetting & "/></a:prop>"
    strRequest = strRequest & "</a:propfind>"
    objXML.send strRequest
    Dim objNodeList
    Set objNodeList = objXML.responseXML.getElementsByTagName("d:x" & strSetting)
    For i = 0 to (objNodeList.length-1)
        Set objNode = objNodeList.nextNode
    Next
    GetXMLSettingValue = objNode.nodeTypedValue
End Function

Function OctetToHexStr (arrbytOctet)
' Function to convert OctetString (byte array) to Hex string.
' Code from Richard Mueller, a MS MVP in Scripting and ADSI
    Dim k
    OctetToHexStr = ""
    For k = 1 To Lenb (arrbytOctet)
        OctetToHexStr = OctetToHexStr & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
    Next
End Function

Function FindADObject (strParameter, strValue) 'Ищет объект общей папки в AD.
    'On Error Resume Next

    set cn = createobject("ADODB.Connection")
    set cmd = createobject("ADODB.Command")
    set rs = createobject("ADODB.Recordset")

    cn.open "Provider=ADsDSOObject;"

    cmd.activeconnection=cn
    cmd.commandtext="SELECT ADsPath FROM 'LDAP://ad1.example.com' WHERE " & strParameter & " = '" & strValue & "'"

    set rs = cmd.execute

    if err<>0 then
        FindADObject="Error connecting to Active Directory Database:" & err.description
    else
        if not rs.BOF and not rs.EOF then
                rs.MoveFirst
                FindADObject = rs(0)
        else 'У меня всего 2 домена, поэтому так грязно. Перепишите, кто-нибудь :)
            cmd.commandtext="SELECT ADsPath FROM 'LDAP://ad2.example.com' WHERE " & strParameter & " = '" & strValue & "'"
            set rs = cmd.execute
            if err<>0 then
                FindADObject="Error connecting to Active Directory Database:" & err.description
            else
                if not rs.BOF and not rs.EOF then
                    rs.MoveFirst
                    FindADObject = rs(0)
                else
                    FindADObject = "Not Found"
                End If
            End If
        end if
    end if
    cn.close

End Function

Function GenerateGUIDForLDAPSearch (strGUID) 'Возвращает строку для поиска общей папки при помощи ф-ии FindADObject
    Counter = 0
    strRes = "\" & Left(strGUID, 2)
    For Counter = 1 To 15
        strTail = Right(strGUID, Len(strGUID)-(Counter*2))
        strPiece = Left (strTail, 2)
        strRes = strRes & "\" & strPiece
    Next
    GenerateGUIDForLDAPSearch = strRes
End Function