' PFRights - Manipulation of user rights on Public Folders
' Backup/Restore for itchy fingered administrators ;-)
' PFAdmin (BORK) is too buggy (I found 4 major bugs) and unhandy for the job...
' Add/Del/Change User is quite useful - if you have more than 1 public folder
'
' (c) Klaus Seeling (), but feel free to redistribute.
' Comments & bug reports are always welcome!
' 2000-08-17, v1.0 (!)
'
' Registered objects needed (via regsvr32.exe):
' - MAPI.Session (CDO.DLL)
' - MSExchange.ACLObject (ACL.DLL)
' If it's not working properly, try creating a new profile
' (the old one may contain more than one "All Public Folders" entry - M$ bug, what else...)
'
' X.500 Username (eg): /o=YourOrg/ou=YourSite/cn=Recipients/cn=YourDN
'
' RightsMask (hex, not all combinations valid!):
' - RIGHTS_NONE = 000
' - RIGHTS_READ_ITEMS = 001
' - RIGHTS_CREATE_ITEMS = 002
' - RIGHTS_EDIT_OWN = 008
' - RIGHTS_DELETE_OWN = 010
' - RIGHTS_EDIT_ALL 020
' - RIGHTS_DELETE_ALL = 040
' - RIGHTS_CREATE_SUBFOLDERS = 080
' - RIGHTS_FOLDER_OWNER = 100
' - RIGHTS_FOLDER_CONTACT = 200
' - RIGHTS_FOLDER_VISIBLE = 400
'
' Folder separator: \/
' Sample: PFRights.vbs MyProfile B 20000816 "Germany\/My Folder"
' If the PF name contains a "\", it must be protected:
' To backup the folder "Test\NewTest" under "Germany", [FolderName] must be written as "Germany\/Test\\NewTest".
' "\" under Germany as "Germany\/\\"
' BTW: Internally we're using chr(30) (Const RS)
'
' You may patch the output files for changing rights - no problem,
' but make sure that there are entries in *_Folders.txt and *_Users.txt for all processed lines in *_Rights.txt.
' Backup & Restore should be straight forward, the script should skip all folders causing problems
' (insufficient rights, folder not replicated, ...).
' In case of errors, please let me know!
'
' Add User:
' Sample: PFRights MyProfile A /o=Yahoo/ou=Moscow/cn=Recipients/cn=KS 7FB "Germany\/My Folder"
' The user with the directory name "KS" will be assigned owner rights on all folders on and under "My Folder"
' (a subfolder of the top-level folder "Germany").
' If the user already had rights on one of the folders, they will be overwritten.
' Delete is similar to Add - should be straight forward, too.
'
' Change User:
' I needed it in 3 cases:
' - A user leaving the company. ACE entries are pointing to the deleted X.500 address.
' - A user leaving the company, replaced by somebody else. Incredible that there's no standard tool...
' - A recreated mailbox.
' can be a deleted account (as long as the ACL entries are still there).
'
' To state the obvious: Change will preserve rights and
' you can't delete (nor change...) the account your profile is using.
' Unfortunately we can't use OPENSTORE_USE_ADMIN_PRIVILEGE outside C++, so make sure we have sufficient rights.
' Funny: "For Each Folder in FolderCollection" is buggy. Some folders are left out!
' I'm using For i = 1 To FolderCollection.Count instead (Thanx to JuergenL!)
'
Const PFInfoStore = &H66310102
Const ObjDistName = &H803C001E
Const MHSCommonName = &H3A0F001E
Const PFId = "000000001A447390AA6611CD9BC800AA002FC45A0300C0B86B30DBD611CEB31700AA00574CC60000000000030000"
Const RS = ""
Const UDefault = "ID_ACL_DEFAULT"
Const UAnonymous = "ID_ACL_ANONYMOUS"
Select Case UCase(Right(WScript.FullName, 11))
Case "WSCRIPT.EXE"
Engine = "W"
Case "CSCRIPT.EXE"
Engine = "C"
End Select
Set FolderDic = CreateObject("Scripting.Dictionary")
Set UserDic = CreateObject("Scripting.Dictionary")
Set RightsDic = CreateObject("Scripting.Dictionary")
Set Args = WScript.Arguments
If Args.Count < 3 Then
DisplayHelp
Else
If Args.Item(0) = "-?" Or Args.Item(0) = "/?" Or Args.Item(0) = "?" Then
DisplayHelp
Else
Select Case UCase(Args.Item(1))
Case "B"
BackupFolders
Case "R"
RestoreFolders
Case "A"
AddUserToFolders
Case "D"
DeleteUserFromFolders
Case "C"
ChangeUserInFolders
Case Else
DisplayHelp
End Select
End If
End If
Sub DisplayHelp()
If Engine = "W" Then
MsgBox "PFRights:" & vbCRLF &_
" Backup/Restore/Change Access Rights to Public Folders" & vbCRLF & vbCRLF &_
"Backup/Restore uses 3 files to store the information:" & vbCRLF &_
"Filename_Folders.txt, Filename_Users.txt and Filename_Rights.txt" & vbCRLF &_
" Folders:" & vbTAB & "FId(=Index){TAB}System Id{TAB}FolderName" & vbCRLF &_
" Users:" & vbTAB & "UId(=Index){TAB}X.500 Name{TAB}Display Name" & vbCRLF &_
" Rights:" & vbTAB & "FId{TAB}UId{TAB}Rights" & vbCRLF & vbCRLF &_
"Usage: PFRights MapiProfileName Mode Parameter(s)" & vbCRLF &_
" Mode:" & vbTAB & "B = Backup, Params: [Foldername]" & vbCRLF & vbTAB &_
"R = Restore, Params: [Foldername]" & vbCRLF & vbTAB &_
"A = Add User, Params: [Foldername]" & vbCRLF & vbTAB &_
"D = Delete User, Params: [Foldername]" & vbCRLF & vbTAB &_
"C = Change User, Params: [Foldername]" & vbCRLF & vbCRLF &_
"If Foldername is not supplied, the action will be performed on all folders." & vbCRLF &_
"Separator: ""\/"". ""\"" in a folder name must be protected -> ""\\""" & vbCRLF & vbCRLF &_
", , ...: Please refer to the source code for additional information." &_
vbCRLF & "Good luck!", vbOKOnly, "Public Folder Rights"
Else
WScript.StdOut.WriteLine "PFRights:"
WScript.StdOut.WriteLine " Backup/Restore/Change Access Rights to Public Folders" & vbCRLF
WScript.StdOut.WriteLine "Backup/Restore uses 3 files to store the information:"
WScript.StdOut.WriteLine "Filename_Folders.txt, Filename_Users.txt and Filename_Rights.txt"
WScript.StdOut.WriteLine " Folders: FId(=Index){TAB}System Id{TAB}FolderName"
WScript.StdOut.WriteLine " Users: UId(=Index){TAB}X.500 Name{TAB}Display Name"
WScript.StdOut.WriteLine " Rights: FId{TAB}UId{TAB}Rights" & vbCRLF
WScript.StdOut.WriteLine "Usage: PFRights MapiProfileName Mode Parameter(s)" & vbCRLF
WScript.StdOut.WriteLine " Mode: B = Backup, Params: [Foldername]"
WScript.StdOut.WriteLine " Mode: R = Restore, Params: [Foldername]"
WScript.StdOut.WriteLine " Mode: A = Add User, Params: [Foldername]"
WScript.StdOut.WriteLine " Mode: D = Delete User, Params: [Foldername]"
WScript.StdOut.WriteLine " Mode: C = Change User, Params: "
WScript.StdOut.WriteLine " [Foldername]"
WScript.StdOut.WriteLine "If ""Foldername"" is not supplied, the action will be performed on all folders."
WScript.StdOut.WriteLine "Separator: ""\/"". ""\"" in a folder name must be protectd -> ""\\""" & vbCRLF
WScript.StdOut.WriteLine ", , ...:"
WScript.StdOut.WriteLine " Please refer to the source code for additional information."
WScript.StdOut.WriteLine "Good luck!"
End If
End Sub
Sub BackupFolders()
If Args.Count = 3 Or Args.Count = 4 Then
If Left(Args.Item(2), 2) <> "\\" And InStr(Args.Item(2), ":") = 0 Then _
OutFilePath = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))
Set MapiSession = CreateObject("MAPI.Session")
MapiSession.Logon Args.Item(0), "", False
Set AllInfoStores = MapiSession.InfoStores
For i = 1 To AllInfoStores.Count
On Error Resume Next
TmpVar = AllInfoStores.Item(i).Fields.Item(PFInfoStore)
If Err.Number = 0 Then
Set PFRoot = AllInfoStores.Item(i).RootFolder
InfoStoreId = AllInfoStores.Item(i).Id
i = AllInfoStores.Count
End If
On Error Goto 0
Next
For i = 1 To PFRoot.Folders.Count
If PFRoot.Folders.Item(i).Id = PFId Then Set PFRootFolder = PFRoot.Folders.Item(i)
Next
EverythingOK = True
FId = 1
UId = 1
FolderFullName = ""
If Args.Count = 4 Then
FolderName = Args.Item(3)
ParseFolderName FolderName, EverythingOK
FolderFullName = RS & FolderName
If EveryThingOK Then
GetSpecificFolder MapiSession, InfoStoreId, PFRootFolder, FolderName, EverythingOK
If EveryThingOK Then EnumParentPF MapiSession, InfoStoreId, FolderDic, UserDic, RightsDic,_
FId, UId, PFRootFolder, FolderFullName
End If
End If
If EverythingOK Then
EnumAllPFs MapiSession, InfoStoreId, FolderDic, UserDic, RightsDic, FId, UId, PFRootFolder, FolderFullName
BackupOutput OutFilePath
End If
Else
DisplayHelp
End If
End Sub
Function ParseFolderName(byRef FolderName, byRef EveryThingOK)
For i = 1 To Len(FolderName)
If Mid(FolderName, i, 1) = "\" Then
i = i + 1
If i > Len(FolderName) Then
EveryThingOK = False
Else
Select Case Mid(FolderName, i, 1)
Case "\"
TmpFolderName = TmpFolderName & "\"
Case "/"
TmpFolderName = TmpFolderName & RS
Case Else
i = Len(FolderName) + 1
EveryThingOK = False
End Select
End If
Else
TmpFolderName = TmpFolderName + Mid(FolderName, i, 1)
End If
Next
If EveryThingOK Then
FolderName = TmpFolderName
Else
If Engine = "W" Then
MsgBox "Invalid folder name!", vbCritical, "Error"
Else
WScript.StdErr.WriteLine "Invalid folder name!"
End If
End If
End Function
Sub GetSpecificFolder(byRef MapiSession, byRef InfoStoreId, byRef PFRootFolder,_
byVal PFRootName, byRef EverythingOK)
Do While EverythingOK And PFRootName <> ""
If InStr(PFRootName, RS) <> 0 Then
FolderNameToSearch = UCase(Left(PFRootName, InStr(PFRootName, RS) - 1))
PFRootName = Right(PFRootName, Len(PFRootName) - Len(FolderNameToSearch) - 1)
Else
FolderNameToSearch = UCase(PFRootName)
PFRootName = ""
End If
For i = 1 To PFRootFolder.Folders.Count
Set PFolderFound = PFRootFolder.Folders.Item(i)
If UCase(PFolderFound.Name) = FolderNameToSearch Then
i = PFRootFolder.Folders.Count + 1
End If
Next
If i = PFRootFolder.Folders.Count + 2 Then
Set PFRootFolder = PFolderFound
Else
EverythingOK = False
If Engine = "W" Then
MsgBox "Folder not found!", vbCritical, "Error"
Else
WScript.StdErr.WriteLine "Folder not found!"
End If
End If
Loop
End Sub
Sub EnumParentPF(byRef MapiSession, byRef InfoStoreId, byRef FolderDic, byRef UserDic,_
byRef RightsDic, byRef FId, byRef UId, byVal PF, byRef FolderFullName)
FolderFullName = FolderFullName & RS & PF.Name
Set ACL = CreateObject("MSExchange.ACLObject")
On Error Resume Next
Set ACL.CdoItem = PF
If Err.Number = 0 Then
On Error Goto 0
Set FolderACEs = ACL.ACEs
On Error Resume Next
If Err.Number = 0 And FolderACEs.Count > 0 Then
On Error Goto 0
FolderDic.Add FId & vbTAB & PF.Id, Right(FolderFullName, Len(FolderFullName) - 1)
For Each FolderACE In FolderACEs
UName = GetACLEntryName(FolderACE.Id, MapiSession)
If Not UserDic.Exists(UName) Then
UserDic.Add UName, UId
UId = UId + 1
End If
RightsDic.Add FId & vbTAB & UserDic.Item(UName), Hex(FolderACE.Rights)
Next
FId = FId + 1
Else
On Error Goto 0
End If
Else
On Error Goto 0
End If
End Sub
Sub EnumAllPFs(byRef MapiSession, byRef InfoStoreId, byRef FolderDic, byRef UserDic,_
byRef RightsDic, byRef FId, byRef UId, byVal PF, byRef FolderFullName)
For i = 1 To PF.Folders.Count
Set SubFolder = PF.Folders.Item(i)
FolderFullName = FolderFullName & RS & SubFolder.Name
Set ACL = CreateObject("MSExchange.ACLObject")
On Error Resume Next
Set ACL.CdoItem = SubFolder
If Err.Number = 0 Then
On Error Goto 0
Set FolderACEs = ACL.ACEs
On Error Resume Next
If Err.Number = 0 And FolderACEs.Count > 0 Then
On Error Goto 0
FolderDic.Add FId & vbTAB & SubFolder.Id, Right(FolderFullName, Len(FolderFullName) - 1)
For Each FolderACE In FolderACEs
UName = GetACLEntryName(FolderACE.Id, MapiSession)
If Not UserDic.Exists(UName) Then
UserDic.Add UName, UId
UId = UId + 1
End If
RightsDic.Add FId & vbTAB & UserDic.Item(UName), Hex(FolderACE.Rights)
Next
FId = FId + 1
Else
On Error Goto 0
End If
Else
On Error Goto 0
End If
EnumAllPFs MapiSession, InfoStoreId, FolderDic, UserDic, RightsDic, FId, UId, SubFolder, FolderFullName
FolderFullName = Left(FolderFullName, InStrRev(FolderFullName, RS) - 1)
Next
End Sub
Function GetACLEntryName(byRef ACLEntryId, byRef MapiSession)
Select Case ACLEntryId
Case UDefault GetACLEntryName = "Default" & vbTAB & "Default"
Case UAnonymous GetACLEntryName = "Anonymous" & vbTAB & "Anonymous"
Case Else
Set TmpEntry = MapiSession.GetAddressEntry(ACLEntryId)
On Error Resume Next
GetACLEntryName = TmpEntry.Fields.Item(ObjDistName) & vbTAB & TmpEntry.Name
If Err.Number <> 0 Then GetACLEntryName = "Unknown" & vbTAB & TmpEntry.Name
On Error Goto 0
End Select
End Function
Sub BackupOutput(byRef OutFilePath)
Set ScriptingFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set RightsOutFile = ScriptingFileSystemObject.CreateTextFile(OutFilePath & Args.Item(2) & "_Rights.txt", True)
For Each RightsDicEntry In RightsDic.Keys
RightsOutFile.WriteLine RightsDicEntry & vbTAB & RightsDic.Item(RightsDicEntry)
Next
RightsOutFile.Close
Set FolderOutFile = ScriptingFileSystemObject.CreateTextFile(OutFilePath & Args.Item(2) & "_Folders.txt", True)
For Each FolderDicEntry In FolderDic.Keys
FolderOutFile.WriteLine FolderDicEntry & vbTAB & FolderDic.Item(FolderDicEntry)
Next
FolderOutFile.Close
Set UserOutFile = ScriptingFileSystemObject.CreateTextFile(OutFilePath & Args.Item(2) & "_Users.txt", True)
For Each UserDicEntry In UserDic.Keys
UserOutFile.WriteLine UserDic.Item(UserDicEntry) & vbTAB & UserDicEntry
Next
UserOutFile.Close
End Sub
Sub RestoreFolders()
Dim AFolders()
Dim AUsers()
Dim AUserObjects()
Dim ARights()
If Args.Count = 3 Or Args.Count = 4 Then
If Left(Args.Item(2), 2) <> "\\" And InStr(Args.Item(2), ":") = 0 Then _
OutFilePath = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))
Set MapiSession = CreateObject("MAPI.Session")
MapiSession.Logon Args.Item(0), "", False
Set AllInfoStores = MapiSession.InfoStores
For i = 1 To AllInfoStores.Count
On Error Resume Next
TmpVar = AllInfoStores.Item(i).Fields.Item(PFInfoStore)
If Err.Number = 0 Then
Set PFRoot = AllInfoStores.Item(i).RootFolder
InfoStoreId = AllInfoStores.Item(i).Id
i = AllInfoStores.Count
End If
On Error Goto 0
Next
For i = 1 To PFRoot.Folders.Count
If PFRoot.Folders.Item(i).Id = PFId Then Set PFRootFolder = PFRoot.Folders.Item(i)
Next
Set ScriptingFileSystemObject = CreateObject("Scripting.FileSystemObject")
PathRoot = OutFilePath & Args.Item(2) & "_"
If ScriptingFileSystemObject.FileExists(PathRoot & "Folders.txt") And _
ScriptingFileSystemObject.FileExists(PathRoot & "Users.txt") And _
ScriptingFileSystemObject.FileExists(PathRoot & "Rights.txt") Then
Set FolderInFile = ScriptingFileSystemObject.OpenTextFile(PathRoot & "Folders.txt")
Set UserInFile = ScriptingFileSystemObject.OpenTextFile(PathRoot & "Users.txt")
Set RightsInFile = ScriptingFileSystemObject.OpenTextFile(PathRoot & "Rights.txt")
FCount = 0
Do Until FolderInFile.AtEndOfLine
FolderInFile.SkipLine
FCount = FCount + 1
Loop
FolderInFile.Close
FCount = FCount - 1
UCount = 0
Do Until UserInFile.AtEndOfLine
UserInFile.SkipLine
UCount = UCount + 1
Loop
UserInFile.Close
UCount = UCount - 1
RCount = 0
Do Until RightsInFile.AtEndOfLine
RightsInFile.SkipLine
RCount = RCount + 1
Loop
RightsInFile.Close
RCount = RCount - 1
ReDim AFolders(FCount, 2)
ReDim AUsers(UCount, 2)
ReDim ARights(RCount, 2)
ReDim AUserObjects(UCount)
Set FolderInFile = ScriptingFileSystemObject.OpenTextFile(PathRoot & "Folders.txt")
For i = 0 To FCount
ReadLn = Split(FolderInFile.ReadLine, vbTAB)
FolderDic.Add ReadLn(0), i
AFolders(i, 0) = ReadLn(0)
AFolders(i, 1) = ReadLn(1)
AFolders(i, 2) = ReadLn(2)
Next
FolderInFile.Close
Set UserInFile = ScriptingFileSystemObject.OpenTextFile(PathRoot & "Users.txt")
For i = 0 To UCount
ReadLn = Split(UserInFile.ReadLine, vbTAB)
UserDic.Add ReadLn(0), i
AUsers(i, 0) = ReadLn(0)
AUsers(i, 1) = ReadLn(1)
AUsers(i, 2) = ReadLn(2)
Set Gal = MapiSession.AddressLists.Item(1)
Set GalAddressEntries = Gal.AddressEntries
Set GalAddressEntriesFilter = GalAddressEntries.Filter
GalAddressEntriesFilter.Name = AUsers(i, 2)
Select Case AUsers(i, 1)
Case "Default"
Case "Anonymous"
Case "Unknown"
Case Else
For Each UserName In GalAddressEntries
If UCase(UserName.Fields.Item(ObjDistName)) = UCase(AUsers(i, 1)) Then
Set AUserObjects(i) = UserName
End If
Next
End Select
Next
UserInFile.Close
Set RightsInFile = ScriptingFileSystemObject.OpenTextFile(PathRoot & "Rights.txt")
For i = 0 To RCount
ReadLn = Split(RightsInFile.ReadLine, vbTAB)
ARights(i, 0) = ReadLn(0)
ARights(i, 1) = ReadLn(1)
ARights(i, 2) = ReadLn(2)
Next
RightsInFile.Close
FId = ""
If Args.Count = 3 Then
For i = 0 To RCount
If FolderDic.Exists(ARights(i, 0)) Then
FolderId = AFolders(FolderDic.Item(ARights(i, 0)), 1)
If FolderId <> FId Then
If FId <> "" Then
On Error Resume Next
ACL.Update
On Error Goto 0
End If
FId = FolderId
Set FolderToSet = MapiSession.GetFolder(FolderId, InfoStoreId)
Set ACL = CreateObject("MSExchange.ACLObject")
Set ACL.CdoItem = FolderToSet
Set FolderACEs = ACL.ACEs
For Each FolderACE In FolderACEs
If FolderACE.Id <> UDefault And FolderACE.Id <> UAnonymous Then
FolderACEs.Delete FolderACE.Id
End If
Next
On Error Resume Next
ACL.Update
On Error Goto 0
Set NewACE = CreateObject("MSExchange.ACE")
End If
Select Case AUsers(UserDic.Item(ARights(i, 1)), 1)
Case "Default"
FolderACEs.Item(UDefault).Rights = ARights(i, 2)
Case "Anonymous"
FolderACEs.Item(UAnonymous).Rights = ARights(i, 2)
Case Else
NewACE.Id = AUserObjects(UserDic.Item(ARights(i, 1))).Id
NewACE.Rights = "&H" + ARights(i, 2)
FolderACEs.Add NewACE
End Select
End If
Next
If FId <> "" Then
On Error Resume Next
ACL.Update
On Error Goto 0
End If
Else
EveryThingOK = True
FolderName = Args.Item(3)
ParseFolderName FolderName, EverythingOK
If EveryThingOK Then
GetSpecificFolder MapiSession, InfoStoreId, PFRootFolder, FolderName, EverythingOK
If EveryThingOK Then
For i = 0 To RCount
If FolderDic.Exists(ARights(i, 0)) Then
If UCase(Left(AFolders(FolderDic.Item(ARights(i, 0)), 2), Len(FolderName))) = UCase(FolderName) Then
FolderId = AFolders(FolderDic.Item(ARights(i, 0)), 1)
If FolderId <> FId Then
If FId <> "" Then
On Error Resume Next
ACL.Update
On Error Goto 0
End If
FId = FolderId
Set FolderToSet = MapiSession.GetFolder(FolderId, InfoStoreId)
Set ACL = CreateObject("MSExchange.ACLObject")
Set ACL.CdoItem = FolderToSet
Set FolderACEs = ACL.ACEs
For Each FolderACE In FolderACEs
If FolderACE.Id <> UDefault And FolderACE.Id <> UAnonymous Then
FolderACEs.Delete FolderACE.Id
End If
Next
On Error Resume Next
ACL.Update
On Error Goto 0
Set NewACE = CreateObject("MSExchange.ACE")
End If
Select Case AUsers(UserDic.Item(ARights(i, 1)), 1)
Case "Default"
FolderACEs.Item(UDefault).Rights = ARights(i, 2)
Case "Anonymous"
FolderACEs.Item(UAnonymous).Rights = ARights(i, 2)
Case Else
NewACE.Id = AUserObjects(UserDic.Item(ARights(i, 1))).Id
NewACE.Rights = "&H" + ARights(i, 2)
FolderACEs.Add NewACE
End Select
End If
End If
Next
If FId <> "" Then
On Error Resume Next
ACL.Update
On Error Goto 0
End If
End If
End If
End If
Else
If Engine = "W" Then
MsgBox "File not found!", vbCritical, "Error"
Else
WScript.StdErr.WriteLine "File not found!"
End If
End If
Else
DisplayHelp
End If
End Sub
Sub AddUserToFolders()
If Args.Count = 4 Or Args.Count = 5 Then
If ("&H" & CStr(Args.Item(3)) And "&H7FB") = ("&H" & CStr(Args.Item(3)) Or 0) Then
Set MapiSession = CreateObject("MAPI.Session")
MapiSession.Logon Args.Item(0), "", False
EverythingOK = False
GetUser MapiSession, Args.Item(2), UserObject, EverythingOK
If EverythingOK Then
Set AllInfoStores = MapiSession.InfoStores
For i = 1 To AllInfoStores.Count
On Error Resume Next
TmpVar = AllInfoStores.Item(i).Fields.Item(PFInfoStore)
If Err.Number = 0 Then
Set PFRoot = AllInfoStores.Item(i).RootFolder
InfoStoreId = AllInfoStores.Item(i).Id
i = AllInfoStores.Count
End If
On Error Goto 0
Next
For i = 1 To PFRoot.Folders.Count
If PFRoot.Folders.Item(i).Id = PFId Then Set PFRootFolder = PFRoot.Folders.Item(i)
Next
EverythingOK = True
FolderFullName = ""
If Args.Count = 5 Then
FolderName = Args.Item(4)
ParseFolderName FolderName, EverythingOK
If EveryThingOK Then
GetSpecificFolder MapiSession, InfoStoreId, PFRootFolder, FolderName, EverythingOK
If EveryThingOK Then
Set ACL = CreateObject("MSExchange.ACLObject")
Set ACL.CDOItem = PFRootFolder
Set PFRootFolderACEs = ACL.ACEs
Set NewACE = CreateObject("MSExchange.ACE")
NewACE.Id = UserObject.Id
NewACE.Rights = "&H" & Args.Item(3)
For Each PFRootFolderACE In PFRootFolderACEs
If GetACLEntry(PFRootFolderACE.Id, MapiSession) = UCase(Args.Item(2)) Then
PFRootFolderACEs.Delete PFRootFolderACE.Id
End If
Next
PFRootFolderACEs.Add NewACE
On Error Resume Next
ACL.Update
On Error Goto 0
End If
End If
End If
If EveryThingOK Then
AddToAllPFs MapiSession, InfoStoreId, UserObject, PFRootFolder
End If
Else
If Engine = "W" Then
MsgBox "User not found!", vbCritical, "Error"
Else
WScript.StdErr.WriteLine "User not found!"
End If
End if
Else
If Engine = "W" Then
MsgBox "Invalid RightsMask!", vbCritical, "Error"
Else
WScript.StdErr.WriteLine "Invalid RightsMask!"
End If
End If
Else
DisplayHelp
End If
End Sub
Sub GetUser(byRef MapiSession, byRef X400UserName, byRef UserObject, byRef EverythingOK)
Set Gal = MapiSession.AddressLists.Item(1)
Set GalAddressEntries = Gal.AddressEntries
Set GalAddressEntriesFilter = GalAddressEntries.Filter
GalAddressEntriesFilter.Fields.Add MHSCommonName, Right(X400UserName, Len(X400UserName) - InStrRev(X400UserName, "="))
For i = 1 To GalAddressEntries.Count
Set User = GalAddressEntries.Item(i)
If UCase(User.Fields.Item(ObjDistName)) = UCase(X400UserName) Then
Set UserObject = User
EverythingOK = True
End If
Next
End Sub
Function GetACLEntry(byRef ACLEntryId, byRef MapiSession)
GetACLEntry = ""
Select Case ACLEntryId
Case UDefault
Case UAnonymous
Case Else
Set TmpEntry = MapiSession.GetAddressEntry(ACLEntryId)
On Error Resume Next
GetACLEntry = UCase(TmpEntry.Fields.Item(ObjDistName))
If Err.Number <> 0 Then GetACLEntry = UCase(TmpEntry.Name)
On Error Goto 0
End Select
End Function
Sub AddToAllPFs(byRef MapiSession, byRef InfoStoreId, byRef UserObject, byVal PF)
For i = 1 to PF.Folders.Count
Set SubFolder = PF.Folders.Item(i)
Set ACL = CreateObject("MSExchange.ACLObject")
On Error Resume Next
Set ACL.CdoItem = SubFolder
If Err.Number = 0 Then
On Error Goto 0
Set FolderACEs = ACL.ACEs
On Error Resume Next
If Err.Number = 0 And FolderACEs.Count > 0 Then
On Error Goto 0
Set NewACE = CreateObject("MSExchange.ACE")
NewACE.Id = UserObject.Id
NewACE.Rights = "&H" & Args.Item(3)
For Each FolderACE In FolderACEs
If GetACLEntry(FolderACE.Id, MapiSession) = UCase(Args.Item(2)) Then
FolderACEs.Delete FolderACE.Id
End If
Next
FolderACEs.Add NewACE
On Error Resume Next
ACL.Update
On Error Goto 0
Else
On Error Goto 0
End If
Else
On Error Goto 0
End If
AddToAllPFs MapiSession, InfoStoreId, UserObject, SubFolder
Next
End Sub
Sub DeleteUserFromFolders()
If Args.Count = 3 Or Args.Count = 4 Then
Set MapiSession = CreateObject("MAPI.Session")
MapiSession.Logon Args.Item(0), "", False
Set AllInfoStores = MapiSession.InfoStores
For i = 1 To AllInfoStores.Count
On Error Resume Next
TmpVar = AllInfoStores.Item(i).Fields.Item(PFInfoStore)
If Err.Number = 0 Then
Set PFRoot = AllInfoStores.Item(i).RootFolder
InfoStoreId = AllInfoStores.Item(i).Id
i = AllInfoStores.Count
End If
On Error Goto 0
Next
For i = 1 To PFRoot.Folders.Count
If PFRoot.Folders.Item(i).Id = PFId Then Set PFRootFolder = PFRoot.Folders.Item(i)
Next
EverythingOK = True
FolderFullName = ""
If Args.Count = 4 Then
FolderName = Args.Item(3)
ParseFolderName FolderName, EverythingOK
If EveryThingOK Then
GetSpecificFolder MapiSession, InfoStoreId, PFRootFolder, FolderName, EverythingOK
If EveryThingOK Then
Set ACL = CreateObject("MSExchange.ACLObject")
Set ACL.CDOItem = PFRootFolder
Set PFRootFolderACEs = ACL.ACEs
For Each PFRootFolderACE In PFRootFolderACEs
If GetACLEntry(PFRootFolderACE.Id, MapiSession) = UCase(Args.Item(2)) Then
PFRootFolderACEs.Delete PFRootFolderACE.Id
End If
Next
On Error Resume Next
ACL.Update
On Error Goto 0
End If
End If
End If
If EverythingOK Then
DeleteFromAllPFs MapiSession, InfoStoreId, UserObject, PFRootFolder
End If
Else
DisplayHelp
End If
End Sub
Sub DeleteFromAllPFs(byRef MapiSession, byRef InfoStoreId, byRef UserObject, byVal PF)
For i = 1 to PF.Folders.Count
Set SubFolder = PF.Folders.Item(i)
Set ACL = CreateObject("MSExchange.ACLObject")
On Error Resume Next
Set ACL.CdoItem = SubFolder
If Err.Number = 0 Then
On Error Goto 0
Set FolderACEs = ACL.ACEs
On Error Resume Next
If Err.Number = 0 And FolderACEs.Count > 0 Then
On Error Goto 0
For Each FolderACE In FolderACEs
If GetACLEntry(FolderACE.Id, MapiSession) = UCase(Args.Item(2)) Then
FolderACEs.Delete FolderACE.Id
End If
Next
On Error Resume Next
ACL.Update
On Error Goto 0
Else
On Error Goto 0
End If
Else
On Error Goto 0
End If
DeleteFromAllPFs MapiSession, InfoStoreId, UserObject, SubFolder
Next
End Sub
Sub ChangeUserInFolders()
If Args.Count = 4 Or Args.Count = 5 Then
Set MapiSession = CreateObject("MAPI.Session")
MapiSession.Logon Args.Item(0), "", False
EverythingOK = False
GetUser MapiSession, Args.Item(3), UserObject, EverythingOK
If EverythingOK Then
Set AllInfoStores = MapiSession.InfoStores
For i = 1 To AllInfoStores.Count
On Error Resume Next
TmpVar = AllInfoStores.Item(i).Fields.Item(PFInfoStore)
If Err.Number = 0 Then
Set PFRoot = AllInfoStores.Item(i).RootFolder
InfoStoreId = AllInfoStores.Item(i).Id
i = AllInfoStores.Count
End If
On Error Goto 0
Next
For i = 1 to PFRoot.Folders.Count
If PFRoot.Folders.Item(i).Id = PFId Then Set PFRootFolder = PFRoot.Folders.Item(i)
Next
EverythingOK = True
FolderFullName = ""
If Args.Count = 5 Then
FolderName = Args.Item(4)
ParseFolderName FolderName, EverythingOK
If EveryThingOK Then
GetSpecificFolder MapiSession, InfoStoreId, PFRootFolder, FolderName, EverythingOK
If EveryThingOK Then
Set ACL = CreateObject("MSExchange.ACLObject")
Set ACL.CDOItem = PFRootFolder
Set PFRootFolderACEs = ACL.ACEs
Set NewACE = CreateObject("MSExchange.ACE")
NewACE.Id = UserObject.Id
For Each PFRootFolderACE In PFRootFolderACEs
If GetACLEntry(PFRootFolderACE.Id, MapiSession) = UCase(Args.Item(2)) Then
NewACE.Rights = PFRootFolderACE.Rights
PFRootFolderACEs.Delete PFRootFolderACE.Id
End If
If GetACLEntry(PFRootFolderACE.Id, MapiSession) = UCase(UserObject.Fields.Item(ObjDistName)) Then
PFRootFolderACEs.Delete PFRootFolderACE.Id
End If
Next
PFRootFolderACEs.Add NewACE
On Error Resume Next
ACL.Update
On Error Goto 0
End If
End If
End If
If EverythingOK Then ChangeAllPFs MapiSession, InfoStoreId, UserObject, PFRootFolder
Else
If Engine = "W" Then
MsgBox "User (new) not found!", vbCritical, "Error"
Else
WScript.StdErr.WriteLine "User (new) not found!"
End If
End if
Else
DisplayHelp
End If
End Sub
Sub ChangeAllPFs(byRef MapiSession, byRef InfoStoreId, byRef UserObject, byVal PF)
For i = 1 to PF.Folders.Count
Set SubFolder = PF.Folders.Item(i)
Set ACL = CreateObject("MSExchange.ACLObject")
On Error Resume Next
Set ACL.CdoItem = SubFolder
If Err.Number = 0 Then
On Error Goto 0
Set FolderACEs = ACL.ACEs
Set NewACE = CreateObject("MSExchange.ACE")
NewACE.Id = UserObject.Id
On Error Resume Next
If Err.Number = 0 And FolderACEs.Count > 0 Then
On Error Goto 0
For Each FolderACE In FolderACEs
If GetACLEntry(FolderACE.Id, MapiSession) = UCase(Args.Item(2)) Then
NewACE.Rights = FolderACE.Rights
FolderACEs.Delete FolderACE.Id
End If
If GetACLEntry(FolderACE.Id, MapiSession) = UCase(UserObject.Fields.Item(ObjDistName)) Then
FolderACEs.Delete FolderACE.Id
End If
Next
FolderACEs.Add NewACE
On Error Resume Next
ACL.Update
On Error Goto 0
Else
On Error Goto 0
End If
Else
On Error Goto 0
End If
ChangeAllPFs MapiSession, InfoStoreId, UserObject, SubFolder
Next
End Sub
This page was last updated on May 01, 2006 04:28 PM.