Set permissions on Outlook Public Folders recursively

It's been a while since I posted a script in here but I thought people might find this one useful. 

It sets a particular permission on an Outlook Public Folder and all folders beneath it (assuming the account running the script has the rights)

One caveat.  You will need to get hold of a copy of ACL.DLL and register it with REGSVR32.  I got my copy from here http://hellomate.typepad.com/exchange/ACL.dll

     Option explicit
 
 Const ExchangeServer = "EXCHANGE SERVER NAME GOES HERE"
 
 Dim AliasUser            :    AliasUser = CreateObject("Wscript.Network").UserName
 
 Dim Session                :    Set Session = CreateObject("MAPI.Session")
 Session.Logon "", "", False, False, True, True, ExchangeServer & vbLf & AliasUser
 
 Dim PFStore                :    Set PFStore = Session.InfoStores.Item("Public Folders")
 Dim RootFolder             :    Set RootFolder = GetTargetRootFolder(Wscript.Arguments(1))
 
 SetPermissions RootFolder,WScript.Arguments(0)
 
 WScript.Echo("Done")
 
 Function GetTargetRootFolder(targetfolder)
     Dim PFRoot        :     Set PFRoot = Session.GetFolder(PFStore.Fields(&H66310102), PFStore.ID).Folders
     Dim objFolder
     
     Set objFolder = PFRoot.GetFirst()
     
     Do Until objFolder.Name = "Directorates General"
         Set objFolder = PFRoot.GetNext()
     Loop
     
     Dim DGRoot        :    Set DGRoot = objFolder.Folders
     Set objFolder = DGRoot.GetFirst()
     
     Do Until objFolder.Name = "Anti-Fraud Office"
         Set objFolder = DGRoot.GetNext()
     Loop
     
     Dim OLAFRoot    :    Set OLAFRoot = objFolder.Folders
     
     Set GetTargetRootFolder = OLAFRoot.Item(targetfolder)
     
 End Function
 
 Sub SetPermissions(folder,OwnerName)
     
     'Use the appropriate permission you want to set
     Const RoleOwner = &H5e3
     Const RolePublishEditor = &H4e3
     Const RoleEditor = &H463
     Const RolePublishAuthor = &H49b
     Const RoleAuthor = &H41b
     Const RoleNoneditingAuthor = &H413
     Const RoleReviewer = &H401
     Const RoleContributor = &H402
     Const RoleNone = &H400
 
     WScript.Echo("updating " & folder.name)
 
     Dim Subfolder
     Dim objACL                :    Set acls = CreateObject("MSExchange.aclobject")
     Dim objACE                :    Set newace = CreateObject("MSExchange.ACE")
     Dim UserObject            :    Set UserObject = GetUserFromGAL(OwnerName,Session)
 
     Set objACL.cdoitem = folder 
     Dim Folder_ACEs    :    Set Folder_ACEs = objACL.aces ' get ACEs for folder
 
     objACE.ID = UserObject.ID
     objACE.rights = RoleOwner
 
     Folder_ACEs.Add objACE '
     objACL.Update ' commit changes to store
     
     If folder.folders.Count > 0 Then
         For Each Subfolder In folder.Folders
             SetPermissions Subfolder, OwnerName
         Next
     End If
 End Sub
 
 Function GetUserFromGAL(userid,MAPISession)
 
     Const AccountName = &H3A00001E
 
     Dim Gal                                     :    Set Gal = MAPISession.AddressLists.Item(1)
     Dim GalAddressEntries             :    Set GalAddressEntries = Gal.AddressEntries
     Dim GalAddressEntriesFilter    :    Set GalAddressEntriesFilter = GalAddressEntries.Filter
     Dim i
     GalAddressEntriesFilter.Fields.Add AccountName, userid
     For i = 1 To GalAddressEntries.Count
         Dim User    :    Set User = GalAddressEntries.Item(i)
         If UCase(User.Fields.Item(AccountName)) = UCase(userid) Then
             Set GetUserFromGAL = User
             Exit For
         End If
     Next
 
 End Function
 

Actually, that script is a little too site specific so just ignore it for now.  I'll make a more modular one.

Here you go, this one's a bit more site-independent.  Mods, please delete the code in the first post.  Thanks

 '==========================================================================
 
 ' NAME: PFRights.vbs
 '
 ' COMMENT:     This script is used to manage Public Folder permissions in Outlook
 '
 ' USAGE:    PFRIGHTS <username> <foldername>
 '
 '==========================================================================
 
 Option Explicit
 
 'Define constants.
 'DefaultRootFolder can be set to a specific Public Folder and the script will start enumerating from there
 
 If WScript.Arguments.Count < 3 Then
     DisplayHelp
 Else
     If WScript.Arguments.Item(0) = "-?" Or WScript.Arguments.Item(0) = "/?" Or WScript.Arguments.Item(0) = "?" Then    DisplayHelp
 End If
 
 Const ExchangeServer = "EXCHANGE SERVER NAME HERE"    
 Const DefaultRootFolder = "" 
 
 'Open an Outlook session with the current user's credentials.  The current user should have appropriate
 'rights to modify Public Folder permissions
 
 Dim AliasUser            :    AliasUser = CreateObject("Wscript.Network").UserName
 
 Dim Session                :    Set Session = CreateObject("MAPI.Session")
 Session.Logon "", "", False, False, True, True, ExchangeServer & vbLf & AliasUser
 
 Dim PFStore                :    Set PFStore = Session.InfoStores.Item("Public Folders")
 Dim RootFolder             :    Set RootFolder = GetTargetRootFolder(Wscript.Arguments(1))
 
 SetPermissions RootFolder,WScript.Arguments(0)
 
 WScript.Echo("Done")
 
 Sub DisplayHelp
     
     'Display script syntax
     Wscript.Echo "PFRights: Change Access Rights to Public Folders" & vbCRLF
     Wscript.Echo "   Usage: PFRights userid PublicFoldername RightsType " & vbCRLF
     Wscript.Echo "   Valid RightsType values are :" & vbCRLF
     Wscript.Echo "   RoleOwner" 
     Wscript.Echo "   RolePublishEditor"
     Wscript.Echo "   RoleEditor"
     Wscript.Echo "   RolePublishAuthor"
     Wscript.Echo "   RoleAuthor"
     Wscript.Echo "   RoleNoneditingAuthor"
     Wscript.Echo "   RoleReviewer"
     Wscript.Echo "   RoleContributor"
     Wscript.Echo "   RoleNone" 
     WScript.Quit
 End Sub
 
 Function GetTargetRootFolder(targetfolder)
     
     'Get the target folder
     Dim objFolder
     Dim FolderPathPart
     Dim FolderPathArray
     Dim FoldersCollection
     
     Set FoldersCollection = Session.GetFolder(PFStore.Fields(&H66310102), PFStore.ID).Folders
     
     'If a DefaultRootFolder was specified then amend the path to the target folder    
     If Not DefaultRootFolder = "" Then targetfolder = DefaultRootFolder & "\" & targetfolder        
         
     FolderPathArray=Split(targetfolder,"\")
     Set objFolder = FoldersCollection.GetFirst()
     
     'Drill down to the target folder
     For Each FolderPathPart In FolderPathArray
         Do Until objFolder.Name = FolderPathPart
             Set objFolder = FoldersCollection.GetNext()
         Loop
     
         Set FoldersCollection = objFolder.Folders
         Set objFolder = FoldersCollection.GetFirst()
     Next
     
     'Return the target folder 
     Set GetTargetRootFolder = objFolder
     
 End Function
 
 Sub SetPermissions(folder,OwnerName)
     
      Const PFFolderPath = &H6707001F
      
      Dim Rights
      
     Select Case WScript.Arguments(2)
         Case "RoleOwner"
             Rights = &H5e3
         Case "RolePublishEditor"
             Rights = &H4e3
         Case "RoleEditor"
             Rights = &H463
         Case "RolePublishAuthor"
             Rights = &H49b
         Case "RoleAuthor"
             Rights = &H41b
         Case "RoleNoneditingAuthor"
             Rights = &H413
         Case "RoleReviewer"
             Rights = &H401
         Case "RoleContributor"
             Rights = &H402
         Case "RoleNone"
             Rights = &H400
         Case Else
     End Select
         
     WScript.Echo("Updating " & folder.fields(PFFolderPath))
     
     Dim Subfolder
     Dim objACL                :    Set objACL = CreateObject("MSExchange.aclobject")
     Dim objACE                :    Set objACE = CreateObject("MSExchange.ACE")
     Dim UserObject            :    Set UserObject = GetUserFromGAL(OwnerName,Session)
     
     'Define a new ACE for this folder
     Set objACL.cdoitem = folder 
     Dim Folder_ACEs    :    Set Folder_ACEs = objACL.aces ' get ACEs for folder
 
     objACE.ID = UserObject.ID
     objACE.Rights = Rights
 
     Folder_ACEs.Add objACE '
     objACL.Update 
     
     'If there are any subfolders, add the same permissions on them too.
     If folder.folders.Count > 0 Then
         For Each Subfolder In folder.Folders
             SetPermissions Subfolder, OwnerName
         Next
     End If
 End Sub
 
 Function GetUserFromGAL(userid,MAPISession)
 
     Const AccountName = &H3A00001E
 
     Dim Gal                        :    Set Gal = MAPISession.AddressLists.Item(1)
     Dim GalAddressEntries        :    Set GalAddressEntries = Gal.AddressEntries
     Dim GalAddressEntriesFilter    :    Set GalAddressEntriesFilter = GalAddressEntries.Filter
     Dim i
     GalAddressEntriesFilter.Fields.Add AccountName, userid
     For i = 1 To GalAddressEntries.Count
         Dim User    :    Set User = GalAddressEntries.Item(i)
         If UCase(User.Fields.Item(AccountName)) = UCase(userid) Then
             Set GetUserFromGAL = User
             Exit For
         End If
     Next
 
 End Function