Option Explicit
' For FileSystemObject
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const TristateTrue = -1
Const TristateUseDefault = -2
Const TristateFalse = 0

'Permission Type: Allow or Deny
Const ADS_ACETYPE_ACCESS_ALLOWED = &H0
Const ADS_ACETYPE_ACCESS_DENIED = &H1
Const ADS_ACETYPE_ACCESS_ALLOWED_OBJECT = &H5
Const ADS_ACETYPE_ACCESS_DENIED_OBJECT = &H6

Const ADS_ACEFLAG_INHERIT_ACE = &H2
Const ADS_ACEFLAG_NO_PROPAGATE_INHERIT_ACE = &H4
Const ADS_ACEFLAG_INHERIT_ONLY_ACE = &H8
Const ADS_ACEFLAG_INHERITED_ACE = &H10
Const ADS_ACEFLAG_VALID_INHERIT_FLAGS = &H1f
Const ADS_ACEFLAG_SUCCESSFUL_ACCESS = &H40
Const ADS_ACEFLAG_FAILED_ACCESS = &H80

'Declare ADSI constants
Const ADS_SCOPE_SUBTREE = 2
Const ADS_OPTION_SECURITY_MASK = 3
Const ADS_OPTION_REFERRALS	= 1
Const ADS_SECURITY_INFO_DACL = 4
Const ADS_CHASE_REFERRALS_NEVER = &h00 
Const ADS_CHASE_REFERRALS_SUBORDINATE = &h20 
Const ADS_CHASE_REFERRALS_EXTERNAL = &h40

'Microsoft Exchange 
Const EX_MB_SEND_AS_ACCESSMASK  = &H00100
Const EX_FULLMAILBOX_ACCESSMASK = 1
Const EX_MB_SEND_AS_GUID = "{AB721A54-1E2F-11D0-9819-00AA0040529B}"

'Application Parameter Index
Const ARG_INDEX_MODE = 0
Const ARG_INDEX_USERNAME = 1
Const ARG_INDEX_FILENAME = 2
Const MIN_ARG = 1

Const MODE_INVALID = -1 
Const MODE_ADD = 0
Const MODE_REMOVE = 1

Const ADD = "-ADD"
Const REMOVE = "-REMOVE"

'Application Const String
Const EMPTYSTRING = ""
Const ERROR_FILENAME = "GrantMailboxPermission.err"
Const OUTPUT_FILENAME = "GrantMailboxPermission.log"
Dim OUTPUT_DELIMITER
OUTPUT_DELIMITER = vbTab

'Logging file
Dim objFSO
Dim objfileError
Dim objfileOutput
Dim objfileImport
Dim objconn
Dim objCommand
Dim rootDSE
Dim sDomainContainer
Dim sUserLDAPPath
Dim objUser
Dim objSDNTsecurity
Dim objDACLNT
Dim objDACLEX
Dim objSDMailbox
Dim fFMA
Dim fSendAs
Dim AccessTypeForFMA
Dim AccessTypeForSendAS
Dim fAddedFMA
Dim fAddedSendAs
Dim fRemovedFMA
Dim fRemovedSendAs
Dim sArraySplit
Dim sOneRow
Dim sGrantedUser
Dim dArgCount
Dim cScriptMode
Dim dArgExpected
Dim fOneError

On Error Resume Next
'Parameter Checking
dArgCount = Wscript.Arguments.Count
If (dArgCount < MIN_ARG) Then
	DisplaySyntax
End If

cScriptMode = MODE_INVALID
Select Case UCase(WScript.Arguments(ARG_INDEX_MODE))
	Case ADD
		cScriptMode = MODE_ADD
		dArgExpected = ARG_INDEX_FILENAME + 1
	Case REMOVE
		cScriptMode = MODE_REMOVE
		dArgExpected = ARG_INDEX_MODE + 1
	Case Else
		cScriptMode = MODE_INVALID
End Select

If (cScriptMode = MODE_INVALID Or dArgCount <> dArgExpected) Then
	DisplaySyntax
End If

If (cScriptMode = MODE_ADD) Then
	sGrantedUser = WScript.Arguments(ARG_INDEX_USERNAME)
	If (IsValidUserName(sGrantedUser) = False) Then
		DisplaySyntax
	End If
End If

CreateImportExportFiles

If (cScriptMode = MODE_ADD) Then
	err.Clear
	
	'Prepare LDAP connection
	Set objconn = CreateObject("ADODB.Connection")
	Set objCommand = CreateObject("ADODB.Command")
	objconn.Provider = "ADSDSOObject"
	objconn.Open "ADs Provider"
	If (err.number <> 0) Then
		WScript.StdOut.WriteLine("Failed to bind to Active Directory server, error:" & err.Description)
		objfileError.WriteLine("Failed to bind to Active Directory server, error:" & err.Description)
		WScript.Quit
	End If
		
	Set rootDSE = GetObject("LDAP://rootDSE")
	sDomainContainer = rootDSE.Get("defaultNamingContext")
	If (err.number <> 0) Then
		WScript.StdOut.WriteLine("Failed to find a Domain Container:" & err.Description)
		objfileError.WriteLine("Failed to find a Domain Container:" & err.Description)
		WScript.Quit
	End If
		
	Set objCommand.ActiveConnection = objconn

	Do While objfileImport.AtEndOfStream <> True
		fOneError = False
		sUserLDAPPath = EMPTYSTRING
		err.Clear

		sOneRow = Trim(objfileImport.ReadLine)
		If sOneRow <> EMPTYSTRING Then
		
		    sUserLDAPPath = GetLDAPPathFromLegacyDN(sOneRow)
		    If (err.number <> 0) Then
			    objfileError.WriteLine("Failed to get user's LDAP path from " & sOneRow)
			    fOneError = True
			    err.Clear
		    End If

		    If (fOneError = False) Then
			    Set objUser = GetObject(sUserLDAPPath)
			    If (err.number <> 0) Then
				    objfileError.WriteLine("Failed to get user object from " & sUserLDAPPath)
				    objfileError.WriteLine("Error: " & err.Description)
				    fOneError = True
				    err.Clear
			    End If
		    End If
    	
		    If (fOneError = False) Then
			    Set objSDMailBox = objUser.MailboxRights
			    Set objDACLEX = objSDMailbox.DiscretionaryAcl
			    Set objSDNTsecurity = objUser.ntSecurityDescriptor
			    Set objDACLNT = objSDNTsecurity.DiscretionaryAcl
			    If (err.number <> 0) Then
				    objfileError.WriteLine("Failed to get DACL of " & sUserLDAPPath)
				    objfileError.WriteLine("Error: " & err.Description)
				    fOneError = True
				    err.Clear
			    End If
		    End If

		    ' Check Full Mailbox Access and Send As permission
		    fFMA = False
		    fSendAs = False
		    AccessTypeForFMA = ADS_ACETYPE_ACCESS_ALLOWED
		    AccessTypeForSendAS = ADS_ACETYPE_ACCESS_ALLOWED

		    If (fOneError = False) Then
			    CheckFullMailboxAccess objDACLEX, sGrantedUser, fFMA, AccessTypeForFMA
			    CheckSendAs objDACLNT, sGrantedUser, fSendAs, AccessTypeForSendAS
			    If (err.number <> 0) Then
				    objfileError.WriteLine("Failed to Check permission of " & sUserLDAPPath)
				    objfileError.WriteLine("Error: " & err.Description)
				    fOneError = True
				    err.Clear
			    End If
		    End If

		    'If we don't have either SendAS or FMA, we're going to add these permission
		    If ( (AccessTypeForFMA = ADS_ACETYPE_ACCESS_DENIED) Or (AccessTypeForSendAs = ADS_ACETYPE_ACCESS_DENIED_OBJECT) ) Then
			    'Deny access already granted, won't add permission to this user
			    objfileError.WriteLine("Deny permission already added: " & sUserLDAPPath)
			    fOneError = True
		    End If
    		
		    If ( fOneError = False And ((fFMA = False) Or (fSendAs = False)) ) Then
			    fAddedFMA = False
			    fAddedSendAs = False
    			
			    If (fFMA = False) Then
				    'Add FMA permission
				    err.Clear
				    AddAce objDACLEX, sGrantedUser, EX_FULLMAILBOX_ACCESSMASK, ADS_ACETYPE_ACCESS_ALLOWED, ADS_ACEFLAG_INHERIT_ACE, 0,0,0
				    objSDMailbox.DiscretionaryAcl = objDACLEX
				    objUser.MailboxRights = Array(objSDMailbox)
				    If ( err.number <> 0 ) Then
					    objfileError.WriteLine("Failed to add FullMailbox Access: " & sUserLDAPPath)
					    objfileError.WriteLine("Error: " & err.Description)
					    fOneError = True
					    fAddedFMA = False
					    err.Clear
				    Else
					    fAddedFMA = True
				    End If
			    End If
    			
			    If (fSendAs = False) Then
				    'Add SendAs permission
				    err.Clear
				    AddAce objDACLNT, sGrantedUser, EX_MB_SEND_AS_ACCESSMASK, ADS_ACETYPE_ACCESS_ALLOWED_OBJECT, 0,1, EX_MB_SEND_AS_GUID, 0
				    objSDNTsecurity.DiscretionaryAcl = objDACLNT
				    objUser.Put "ntSecurityDescriptor", Array( objSDNTsecurity )
				    objUser.SetOption ADS_OPTION_SECURITY_MASK, ADS_SECURITY_INFO_DACL
				    If ( err.number <> 0 ) Then
					    objfileError.WriteLine("Failed to add SendAs permission: " & sUserLDAPPath)
					    objfileError.WriteLine("Error: " & err.Description)
					    fOneError = True
					    fAddedSendAs = False
					    err.Clear
				    Else
					    fAddedSendAs = True
				    End If
			    End If

			    If (fOneError = False ) Then 
				    objUser.SetInfo
				    If (err.number <> 0) Then
					    objfileError.WriteLine("Failed to update user: " & sUserLDAPPath)
					    objfileError.WriteLine("Error: " & err.Description)
					    fOneError = True
					    err.Clear		
				    Else
					    'Update Logging
					    objfileOutput.WriteLine(sUserLDAPPath & OUTPUT_DELIMITER & fAddedFMA & OUTPUT_DELIMITER & fAddedSendAs)		
				    End If
			    End If
		    End If

		    Set objUser = Nothing
		    Set objSDNTsecurity = Nothing
		    Set objDACLNT = Nothing
		    Set objDACLEX = Nothing
		    Set objSDMailBox = Nothing

		    If (fOneError = True) Then
			    WScript.StdOut.Write("!")
		    Else
			    WScript.StdOut.Write(".")
		    End If
        End If
	Loop

Set rootDSE = Nothing
Set objCommand = Nothing
Set objconn = Nothing

End If

If (cScriptMode = MODE_REMOVE) Then
	'Retreive the granted user from the first line of import file
	sGrantedUser = objfileImport.ReadLine
	If (IsValidUserName(sGrantedUser) = False) Then
		WScript.StdOut.WriteLine("Invalid User in import file. please check import file..")
		objfileError.WriteLine("Invalid User in import file. please check import file..")
		WScript.Quit
	End If
	
	Do While objfileImport.AtEndOfStream <> True
		fOneError = False
		sUserLDAPPath = EMPTYSTRING
		fAddedFMA = False
		fAddedSendAs = False
		fRemovedFMA = False
		fRemovedSendAs = False
		err.Clear

		sOneRow = objfileImport.ReadLine
		sArraySplit = Split(sOneRow, OUTPUT_DELIMITER)

		'First column is Ldap path
		sUserLDAPPath = sArraySplit(0)
		'Second column is FullMailbox Permission
		fAddedFMA = sArraySplit(1)
		'Third column is SendAs
		fAddedSendAs = sArraySplit(2)

		Set objUser = GetObject(sUserLDAPPath)
		If (err.number <> 0) Then
			objfileError.WriteLine("Failed to get user object from " & sUserLDAPPath)
			objfileError.WriteLine("Error: " & err.Description)
			fOneError = True
			err.Clear
		End If
		
		If ((fOneError = False) And (fAddedFMA = "True")) Then		
			Set objSDMailBox = objUser.MailboxRights
			Set objDACLEX = objSDMailbox.DiscretionaryAcl
			fRemovedFMA = RemoveFullMailboxAccess(objDACLEX, sGrantedUser)
			If (err.number <> 0) Then
				objfileError.WriteLine("Failed to Remove Full MailboxAccess from " & sUserLDAPPath)
				objfileError.WriteLine("Error: " & err.Description)
				fOneError = True
				err.Clear
			End If
			
			If (fRemovedFMA = False) Then
				objfileError.WriteLine("Couldn't find Full mailbox access permission on " & sUserLDAPPath)
			End If
			
			If ((fOneError = False) And (fRemovedFMA = True)) Then
				objSDMailbox.DiscretionaryAcl = objDACLEX
				objUser.MailboxRights = Array(objSDMailbox)
			End If
		End If

		If ((fOneError = False) And (fAddedSendAs = "True")) Then		
			Set objSDNTsecurity = objUser.ntSecurityDescriptor
			Set objDACLNT = objSDNTsecurity.DiscretionaryAcl

			fRemovedSendAs = RemoveSendAs(objDACLNT, sGrantedUser)
			If (err.number <> 0) Then
				objfileError.WriteLine("Failed to Remove SendAs from " & sUserLDAPPath)
				objfileError.WriteLine("Error: " & err.Description)
				fOneError = True
				err.Clear
			End If

			If (fRemovedSendAs = False) Then
				objfileError.WriteLine("Couldn't find SendAs permission on " & sUserLDAPPath)
			End If
			
			If ((fOneError = False) And (fRemovedSendAs = True)) Then
				objSDNTsecurity.DiscretionaryAcl = objDACLNT
				objUser.Put "ntSecurityDescriptor", Array( objSDNTsecurity )
				objUser.SetOption ADS_OPTION_SECURITY_MASK, ADS_SECURITY_INFO_DACL
			End If
		End If

		If ((fOneError = False) And (fRemovedFMA Or fRemovedSendAs)) Then
			objUser.SetInfo
			If (err.number <> 0) Then
				objfileError.WriteLine("Failed to update ADSI for user: " & sUserLDAPPath)
				objfileError.WriteLine("Error: " & err.Description)
				fOneError = True
				err.Clear		
			Else 
				If ( fRemovedFMA Or fRemovedSendAs ) Then
					'Update Logging
					objfileError.WriteLine("Removed Permission from " & sUserLDAPPath & OUTPUT_DELIMITER & fRemovedFMA & OUTPUT_DELIMITER & fRemovedSendAs)
				End If
			End If
		End If

		If (fOneError = True) Then
			WScript.StdOut.Write("!")
		Else
			WScript.StdOut.Write(".")
		End If
	Loop
End If

CloseImportexportFiles

Function IsValidUserName (sUserName)
	Dim dPosition
	dPosition = InStr(1, sUserName, "\")
	If (dPosition = 0 ) Then
		IsValidUserName = False
		objfileError.WriteLine("Invalid User:" & sUserName)
	Else
		IsValidUserName = True
	End If
End Function

Function CheckSendAs (objNTSD, sUser, fSendAs, AccessType)
	Dim intACECount
	Dim objACE
	
	err.Clear
	fSendAs = False
	AccessType = ADS_ACETYPE_ACCESS_ALLOWED
	intACECount = objNTSD.AceCount

	If intACECount Then
		For Each objACE In objNTSD
			err.Clear
			If ( (UCase(objACE.Trustee) = UCase(sUser)) And (objACE.ObjectType = EX_MB_SEND_AS_GUID) ) Then
				fSendAs = True
				AccessType = objACE.AceType
			End If
		Next
	End If	

	If (err.number <> 0) Then
		objfileError.WriteLine("Check SendAs permissions Failed : " & sUser)
		objfileError.WriteLine("Error: " & err.Description)
		err.Clear
		fOneError = True
	End If
	Set objACE = Nothing
End Function

Function CheckFullMailboxAccess (objACL, sUser, fFoundFMA, AccessType)
	Dim intACECount
	Dim objACE

	err.Clear
	fFoundFMA = False
	AccessType = ADS_ACETYPE_ACCESS_ALLOWED
	intACECount = objACL.AceCount
	If intACECount Then
		For Each objACE In objACL
			If ( (UCase(objACE.Trustee) = UCase(sUser)) And ((objACE.AccessMask And EX_FULLMAILBOX_ACCESSMASK) <> 0)) Then
				fFoundFMA = True
				AccessType = objACE.AceType
			End If
		Next
	End If

	If (err.number <> 0) Then
		objfileError.WriteLine("Check FullMailbox permissions Failed : " & sUser)
		objfileError.WriteLine("Error: " & err.Description)
		err.Clear
		fOneError = True
	End If
	Set ObjACE = Nothing
End Function

Function RemoveSendAs (objNTSD, sUser)
	Dim intACECount
	Dim objACE
	Dim fFound
	
	fFound = False
	intACECount = objNTSD.AceCount
	
	If intACECount Then
		For Each objACE In objNTSD
			If ((UCase(objACE.Trustee) = UCase(sUser)) And (objACE.ObjectType = EX_MB_SEND_AS_GUID) ) Then
				objNTSD.RemoveAce objACE
				fFound = True
			End If
		Next
	End If

	RemoveSendAs = fFound		
End Function

Function RemoveFullMailboxAccess (objACL, sUser)
	Dim intACECount
	Dim objACE
	Dim fFound
	
	fFound = False
	intACECount = objACL.AceCount
	
	If intACECount Then
		For Each objACE In objACL
			If((0 <> Instr(UCase(objACE.Trustee), UCase(sUser))) And (objACE.AccessMask And EX_FULLMAILBOX_ACCESSMASK) <> 0) Then
				objACE.AccessMask = (objACE.AccessMask Xor EX_FULLMAILBOX_ACCESSMASK)
				fFound = True
			End If
		Next
	End If

	RemoveFullMailboxAccess = fFound		
End Function

Function GetLDAPPathFromLegacyDN (sLegacyDN)
	Dim rsUsers
	Dim sLdapPath
	
	objCommand.CommandText = "<GC://" & sDomainContainer & ">;(&(&(& (mailnickname=*) (| (&(objectCategory=person)(objectClass=user)(legacyExchangeDN=" & sLegacyDN & ")) ))));adspath;subtree"
	objCommand.Properties("searchscope") = ADS_SCOPE_SUBTREE
	objCommand.Properties("Page Size") = 10
	objCommand.Properties("Timeout") = 30 
	objCommand.Properties("Chase referrals") = (ADS_CHASE_REFERRALS_SUBORDINATE Or ADS_CHASE_REFERRALS_EXTERNAL)

	err.Clear	
	Set rsUsers = objCommand.Execute
	If (err.number <> 0) Then
		objfileError.WriteLine("Search for mailbox owners failed, error:" & err.Description)
		fOneError = True
	End If
	
	If (rsUsers.RecordCount = 0) Then
		objfileError.WriteLine("No mailbox owner user accounts found for " & sLegacyDN & " in " & sDomainContainer & ".")
		fOneError = True		
	End If

	If (rsUsers.RecordCount > 1) Then
		objfileError.WriteLine("Multiple mailboxs owner user accounts found for " & sLegacyDN & " in " & sDomainContainer & ".")
		fOneError = True		
	End If

	sLdapPath = Replace(rsUsers.Fields(0).Value, "GC://", "LDAP://")	
	GetLDAPPathFromLegacyDN = sLdapPath
	Set rsUsers = Nothing
End Function

Function CloseImportexportFiles

	objfileError.WriteLine("*******************************************************")
	objfileError.WriteLine("End at " & Date & " " & Time)
	objfileError.WriteLine("*******************************************************")

	objFSO.Close
	objfileError.Close
	objfileOutput.Close
	objfileImport.Close
	
	Set objFSO = Nothing
	Set objfileError = Nothing
	Set objfileOutput = Nothing
	Set objfileImport = Nothing
End Function

Function CreateImportExportFiles
	Dim sErrorsFileName
	Dim sImportFileName
	Dim sOutputFileName

	err.Clear
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	sErrorsFileName = ERROR_FILENAME
	sImportFileName = EMPTYSTRING
	sOutputFileName = EMPTYSTRING

	Select Case cScriptMode
		Case MODE_ADD
			sImportFileName = WScript.Arguments(ARG_INDEX_FILENAME)
			sOutputFileName = OUTPUT_FILENAME
		Case MODE_REMOVE
			sImportFileName = OUTPUT_FILENAME 'Use output file name as import file
			sOutputFileName = EMPTYSTRING	
		Case Else
			DisplaySyntax
	End Select

	Set objfileError = objFSO.OpenTextFile(sErrorsFileName, ForAppending, True, TristateTrue)
	objfileError.WriteLine("*******************************************************")
	objfileError.WriteLine("Start at " & Date & " " & Time)
	objfileError.WriteLine("*******************************************************")

	If (cScriptMode = MODE_REMOVE) Then
		Set objfileImport = objFSO.OpenTextFile(sImportFileName, ForReading, False, TristateTrue)
	Else
		Set objfileImport = objFSO.OpenTextFile(sImportFileName, ForReading, False, TristateFalse)
	End If

	If (sOutputFileName <> EMPTYSTRING) Then
		'Check if output file already exists.
		If (objFSO.FileExists(sOutputFileName)) Then
			Set objfileOutput = objFSO.OpenTextFile(sOutputFileName, ForReading, False, TristateTrue)
			sOneRow = objfileOutput.ReadLine
			'If user name in the file is different from parameter, we can not proceed.'
			If ( sOneRow <> sGrantedUser ) Then
				WScript.StdOut.WriteLine("The Domain\User must be the same as " & sOneRow )
				WScript.Quit
			End If
			Set objfileOutput = objFSO.OpenTextFile(sOutputFileName, ForAppending, True, TristateTrue)
		Else
			Set objfileOutput = objFSO.OpenTextFile(sOutputFileName, ForWriting, True, TristateTrue)
			'The first line of Log file is the user who is going to be granted the permissions
			objfileOutput.WriteLine(sGrantedUser)
		End If
	End If
	
	If (err.number <> 0) Then
		WScript.StdOut.WriteLine("Failed to open Log file, error:" & err.Description)
		WScript.Quit
	End If
End Function

Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
	Dim Ace1
	
	Set Ace1 = CreateObject("AccessControlEntry")
	Ace1.AccessMask = gAccessMask
	Ace1.AceType = gAceType
	Ace1.AceFlags = gAceFlags
	Ace1.Flags = gFlags
	Ace1.Trustee = TrusteeName
	'Determine whether ObjectType has to be set
	If CStr(gObjectType) <> "0" Then
		Ace1.ObjectType = gObjectType
	End If

	'Determine whether InheritedObjectType has to be set.
	If CStr(gInheritedObjectType) <> "0" Then
		Ace1.InheritedObjectType = gInheritedObjectType
	End If
	dacl.AddAce Ace1

    Set Ace1 = Nothing
End Function

Function DisplaySyntax
	WScript.StdOut.WriteLine("Syntax:")
	WScript.StdOut.WriteLine()
	WScript.StdOut.WriteLine("Grant Full mailbox access and SendAs permission to USER based on IMPORT_FILE:")
	WScript.StdOut.WriteLine("    CSCRIPT " & WScript.ScriptName & " -Add DOMAIN\USER IMPORT_FILE")
	WScript.StdOut.WriteLine("    NOTE: """ & OUTPUT_FILENAME & """ will be created for -Remove option ")
	WScript.StdOut.WriteLine()
	WScript.StdOut.WriteLine("Remove Full mailbox access and SendAs permission based on " & OUTPUT_FILENAME & ":")
	WScript.StdOut.WriteLine("    CSCRIPT """ & WScript.ScriptName & """ -Remove ")
	WScript.StdOut.WriteLine()
	WScript.StdOut.WriteLine("For all modes, errors are saved to " & ERROR_FILENAME )

	WScript.Quit	
End Function

Back to the top