This is a script called "MailGuard" that I created for controlling internal email Ids from sending mail to other email Ids/domains.
This is an "Allow" based script and its my first attempt, so please do share your feedback and let me know if it helps you.
Apart from the script which has to be defined in EventHandlers.vbs, you should define your Allow rules in a file called Rules.csv.
Rules.csv file has the following fields-
RuleId, FromEmail, ToEmail -
RuleId is a counter.
FromEmail is the internal ID on which the filter is going to be applied.
ToEmail is the definition of the email/domain to which the allow rule is being set.
The script implements the rules like this -
1)If an internal email ID is not defined in rules.csv, then there are no restrictions for this email ID and it can send mail to all domains.
2)If an internal email ID *is* defined in rules.csv, then mails are allowed *only* to the email IDs mentioned in the rules.csv file and everything else is blocked.
Here's the scenario:
1. User CEO@goodDomain.com should send mail to everyone with no restrictions
2. User joe@goodDomain.com should send mail only to other users at goodDomain.com and all external domains must be blocked
3. User jill@goodDomain.com should send mail only to someone@badDomain.com and everyone at goodDomain.com
This is how you would set up rules.csv:
CEO@goodDomain.com should not be mentioned in rules.csv at all
The script is given below-
Code: Select all
Sub OnAcceptMessage(oClient, oMessage) On Error Resume Next 'Start of MailGuard settings 'Log - logging True=enabled False=Disabled Dim Log: Log = False 'Be sure to set the path to where to save logs if enabled above!! IT MUST EXIST if logging enabled Dim StrSave: StrSave = "C:\hmaillog" Const adOpenStatic = 3 Const adLockOptimistic = 3 Const adCmdText = &H0001 'Path to the rules.csv file strPathtoRulesFile = "C:\vbscripts\" Set objConnection = CreateObject("ADODB.Connection") Set objRecordSet = CreateObject("ADODB.Recordset") Set objRuleSet = CreateObject("ADODB.Recordset") objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & strPathtoRulesFile & ";" & _ "Extended Properties=""text;HDR=YES;FMT=Delimited""" 'End of Settings REM If the sender email id is not in the table -> allow to all domains *.* REM If the sender email id is in the table -> block all UNLESS REM -Recipient email id is defined (or) REM -Recipient email id domain wildcard is defined. 'if Log Then Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject") 'if Log Then Dim FSOStream: Set FSOStream = FSO.OpenTextFile(StrSave & "\" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "-MailGuard.log",8,True) 'if Log Then FSOStream.WriteLine Now & " MailGuard Starting" Dim SendMail SendMail = true Dim recipientDomain Dim rejectReason set obRecipients = oMessage.Recipients 'FSOStream.Writeline "Number of recipients:" & obRecipients.count 'First check if the SenderEmail address is defined in the rule list. objRecordset.Open "SELECT count(*) as C FROM rules.csv where FromEmail=""" & oMessage.FromAddress & """", _ objConnection, adOpenStatic, adLockOptimistic, adCmdText 'FSOStream.WriteLine Now & objRecordSet.Fields("C") & " Rules found for : " & oMessage.FromAddress If cint(objRecordset.Fields(0)) > 0 then 'The sender email Id has been defined in the rules. By default, ALL mails to ALL recipients will be blocked, unless all recipients to this message 'have been defined in the ToEmail field as Allow rules SendMail=false 'Now loop through each recipient to this email. for i = 0 to obRecipients.Count -1 set obRecipient = obRecipients.Item(i) 'FSOStream.WriteLine Now & " Recipient: " & obRecipient.Address 'Identify the recipient's domain recipientDomain = Mid(obRecipient.Address, InstrRev(obRecipient.Address,"@")+1, len(obRecipient.Address)-InstrRev(obRecipient.Address,"@")) 'FSOStream.WriteLine Now & "Domain: " & recipientDomain 'Check if the recipient address OR the recipient domain is mentioned in ToEmail for this FromEmail address sqlCmd = "SELECT count(*) FROM rules.csv where fromEmail=""" & oMessage.FromAddress & """ and (ToEmail=""" & obRecipient.Address & """ OR toEmail=""*@" & recipientDomain & """)" 'FSOStream.WriteLine Now & "SQL: " & sqlCmd objRuleSet.close objRuleSet.Open sqlCmd, objConnection, adOpenStatic, adLockOptimistic, adCmdText If cint(objRuleSet.Fields(0)) = 0 then 'No allow rules available for the recipient and/or *@recipient domain, so set sendMail=false and terminate the loop SendMail = false rejectReason = oMessage.FromAddress & " cannot send mail to " & obRecipient.Address 'Write to hMail event log EventLog.Write("MailGuard: The email with subject: " & oMessage.subject & " is BLOCKED because " & rejectReason) else SendMail = true end if 'Terminate the loop immdly If sendMail=false then exit for Next End If objRuleSet.close objRecordSet.close objRuleSet = nothing objRecordset = nothing 'FSOStream.close If SendMail = false then Result.Message = rejectReason Result.Value = 2 End If End Sub
If you would rather use a database table instead of a csv file, change the way the ObjConnection is opened. You would also have to change the way objRuleset.open is called (remove adcmd option)
Thanks and creds to the other posters from whom I picked up bits and pieces.