'=========================================================================
' GroupModifyMessageRestrictions.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: https://sigkillit.com
' DATE: 1/1/2011
' COMMENTS: Modifies Messages Restrictions on Email Enabled Groups as Shown
' on the Exchange General Tab under the Properties. Set the Group Path,
' Whether to Only Accept Messages from Authenticated Users, the Restriction
' Type, and an Array of Groups/Users that Can Send to the List. The Array Can
' Contain the Distinguised Name or SMTP Email Address of the Group/User. To Bulk
' Modify Groups, Set the Group Path to an Organizational Unit or Container Path.
' EXAMPLE: Only Allow Joe Smith and jdoe@domain.com To Send to All Distribution Lists in OU
' strGroupPath = "LDAP://OU=Distribution Lists,DC=domain,DC=com"
' blnAuthenticate = False
' strRestriction = "only from"
' arrList = Array("CN=Joe Smith,CN=Users,DC=domain,DC=com","jdoe@domain.com")
' EXAMPLE: All Everyone to Send To a Distribution List Called Test
' strGroupPath = "LDAP://CN=Test,CN=Users,DC=domain,DC=com"
' blnAuthenticate = False
' strRestriction = "only from"
' (*Note: Remove the arrList Line For This to Work)
' EXAMPLE: Only Allow Autheniticated Users to Send to a Distribution List Called Test
' strGroupPath = "LDAP://CN=Test,CN=Users,DC=domain,DC=com"
' blnAuthenticate = True
' strRestriction = "only from"
' (*Note: Remove the arrList Line For This to Work)
'=========================================================================
Option Explicit
' ------ START CONFIGURATION ------
Dim strGroupPath, blnAuthenticate, strRestriction, arrList
strGroupPath = "LDAP://OU=Distribution Lists,DC=domain,DC=com"
blnAuthenticate = False
strRestriction = "only from"
arrList = Array("CN=Joe Smith,CN=Users,DC=domain,DC=com","jdoe@domain.com")
' ------ END CONFIGURATION ------
Call Logger("GroupModifySenderRestrictions.txt", "", True)
strGroupPath = Replace(strGroupPath,"LDAP://","",1,1,1) 'Ensure DN not ADS Path
Dim objConnection: Set objConnection = CreateObject("ADODB.Connection")
Dim objCommand: Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000 'Override the Return 1000 Results Default
Const ADS_SCOPE_SUBTREE = 2
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 'Include Sub OU's
objCommand.CommandText = "SELECT ADsPath FROM 'LDAP://" & strGroupPath & "' WHERE objectClass='group'"
Dim objRecordSet: Set objRecordSet = objCommand.Execute
objRecordSet.MoveFirst
Dim objGroup, blnErr, strResult: strResult = ""
Do Until objRecordSet.EOF
If ModifyRestrictions(objRecordSet.Fields("AdsPath").Value, blnAuthenticate, strRestriction, arrList) = True Then
Call Logger("GroupModifySenderRestrictions.txt", "Success" & vbTab & objRecordSet.Fields("AdsPath").Value, False)
Else
Call Logger("GroupModifySenderRestrictions.txt", "!~ERROR~!" & vbTab & objRecordSet.Fields("AdsPath").Value, False)
End If
objRecordSet.MoveNext
Loop
Wscript.Echo "Finished"
Private Function ModifyRestrictions(groupDN, blnAuth, restrictionType, arrMembers)
On Error Resume Next
groupDN = Replace(groupDN,"LDAP://","",1,1,1) 'Ensure DN not ADS Path
Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
Const cdoexmAccept = 0
Const cdoexmReject = 1
If StrComp(Trim(restrictionType),"from everyone",1) = 0 Then
objGroup.RestrictedAddresses = cdoexmAccept
Elseif StrComp(Trim(restrictionType),"only from",1) = 0 Then
objGroup.RestrictedAddresses = cdoexmAccept
Elseif StrComp(Trim(restrictionType),"from everyone except",1) Then
objGroup.RestrictedAddresses = cdoexmReject
End If
objGroup.msExchRequireAuthToSendTo = blnAuth
objGroup.RestrictedAddressList = arrMembers
objGroup.SetInfo
If Err.Number <> 0 Then
ModifyRestrictions = FALSE
Else
ModifyRestrictions = TRUE
End If
On Error GoTo 0
End Function
Private Sub Logger(fileName, logMessage, blnNewLog)
On Error Resume Next
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
Dim logName
If InStr(1,fileName,"\",1) > 0 Then
logName = fileName
If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
If Not objFSO.FolderExists(logName) Then
If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
objFSO.CreateFolder logName 'Create Folder In Current Path
Exit Sub
Else
Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
Exit Sub
End If
End If
Else
If Not objFSO.FileExists(logName) Then
If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
End If
End If
End If
End If
Else
logName = scriptPath & fileName
End If
Dim logFile
If blnNewLog = True Then
Set logFile = objFSO.CreateTextFile(logName, True)
Else
If objFSO.FileExists(logName) Then
Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
Else
Set logFile = objFSO.CreateTextFile(logName, True)
End If
End If
logFile.WriteLine logMessage
logFile.Close
Set objFSO = Nothing
On Error Goto 0
End Sub
