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
Rules.csv
RuleId,FromEmail,ToEmail
1,joe@goodDomain.com,*@gooddomain.com
2,jill@gooddomain.com,*@gooddomain.com
3,jill@gooddomain.com,someone@baddomain.com
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 SubIf 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.
Regards
Prashanth
Whoops, that was certainly the problem in this case. It doesn't appear to be generating that file, though.