Internet Handholding posted on October 19, 2009 21:36

Updated the code to handle mixed case in the various places strings are compared.
'----------------------------------------------------
'Copyright (c) 2009 to present Bronze Inc. All rights reserved.
'Visit www.Programmer.bz
'----------------------------------------------------
'Outlook_Email_Item_Send_Class
'
'This class checks these things
'1. Sending to more than one domain
'2. Forwarding to a domain other than the safe domain
'3. The subject line is not blank
'4. Missing Attachment
'----------------------------------------------------
'Call from the Application_ItemSend event
'----------------------------------------------------
'Private Sub Application_ItemSend(ByVal item As Object, cancel As Boolean)
' Dim email As mailitem
' Set email = item
' If email.Class <> olMail Then Exit Sub 'Make sure it is a mail message and not a task or something else
' Dim emailchecker As Outlook_Email_Item_Send_Class
' Set emailchecker = New Outlook_Email_Item_Send_Class
' If Not emailchecker.Item_Send_Check(email) Then
' cancel = True
' email.Display
' End If
'End Sub
'----------------------------------------------------
'Properties you can change to your own liking
'----------------------------------------------------
Public domain_list As String 'Domains in message
Public domain_count As Integer 'Number of domains being sent to
Public domain_safe As Boolean 'If all domains are safe domains
Public file_initialize As String 'File to set properties
Public file_path_initialize As String 'File to set properties
Public is_forward As Boolean 'Is forward
Public is_reply As Boolean 'Is reply
Public message As String 'Message to display in message box
Public message_answer_yes As Boolean 'True for yes means send, false for yes means cancel
Public property_check_attachment As Boolean
Public property_check_domain_multiple As Boolean
Public property_check_domain_forward As Boolean
Public property_check_subject As Boolean
Public property_minimum_subject_length As Integer
Public recipient_list As String 'Recipients in message
Public set_warning_domain_multiple 'Set to true if this is used
Public subject_colon As Boolean 'Colon in subject
Public subject_length As Integer 'Length after colon if there is one
Public text_send_message_abort As String 'Ask not send email
Public text_send_message_now As String 'Ask to send email
Public text_sep As String 'Separate lists items in string
Public text_sep_email As String 'Separate email addresses for display
Public text_warn_attachment As String
Public text_warn_domain_forward As String
Public text_warn_domain_multiple As String
Public text_warn_subject_length As String
Public text_warn_subject_length_colon As String
Public use_attach_words As String 'Words to look for attachment
Public use_domain_safe As String 'Domains alright to forward to
Public use_forward_words As String 'Fowarding words
Public use_reply_words As String 'Reply words starting subject
'----------------------------------------------------
'Initialize properties when class is initialized
'----------------------------------------------------
Private Sub Class_Initialize()
domain_count = 0 'Number of domains being sent to
domain_list = "" 'Domains being sent to
domain_safe = True 'If all domains are safe domains
file_initialize = "outlook_email.ini"
file_path_initialize = "C:\Documents and Settings\" + Environ("username") _
+ "\My Documents\u\outlook\info\"
is_forward = False
is_reply = False
message = "" 'Initialize to no message
message_answer_yes = True 'True for yes means send, false for yes means cancel
property_check_attachment = True 'Check for attachment words
property_check_domain_multiple = True 'Initialize to check for multiple domains
property_check_domain_forward = True 'Check for forwarding to other domains
property_check_subject = True 'Check subject line
property_minimum_subject_length = 3 'Minimum length to avoid message
recipient_list = "" 'List of recipients
set_warning_domain_multiple = False 'Set warning that messages sent to mulitple domains
subject_colon = False 'Colon in subject
subject_length = -1 'Subject length
text_send_message_abort = "Edit message now and do not send?"
text_send_message_now = "Send message now anyway?"
text_sep = "," 'General separator for lists
text_sep_email = ", " 'Separator for email display
text_warn_attachment = "Warning, no attachment."
text_warn_domain_forward = "Warning, forwarding to domains other than "
text_warn_domain_multiple = "Warning, sending to multiple domains."
text_warn_subject_length = "Warning, subject too short." + vbCrLf + "Minimum number of characters is "
text_warn_subject_length_colon = "Warning, subject too short after colon." + vbCrLf + "Minimum number of characters is "
use_attach_words = "attach,enclos" 'Words to look for attachment
use_domain_safe = "agtsi.com" 'Domains alright to forward to
use_forward_words = "fw:,fwd:"
use_reply_words = "re:"
End Sub
Public Sub Class_Init()
Dim lines_init(100) As String 'To read in initialization file
'Dim filereader As File_Class
'Set filereader = New File_Class
'filereader.Readlines(lines_init, file_path_initialize + file_initialize)
End Sub
'----------------------------------------------------
'Check for the words "attach,enclos" in the subject
'or body of the message. If found and there is no
'attachment, warn the sender
'----------------------------------------------------
Public Sub Check_Attachment(mailitem As Outlook.mailitem)
Dim num As Integer
num = mailitem.Attachments.count
If num > 0 Then Exit Sub 'There are attachments
'---- Check subject and body of message for key words that indicate an attachment
Dim awords() As String
awords = Split(LCase(use_attach_words), ",")
num = UBound(awords)
If num < 0 Then Exit Sub 'No words to check
Dim body As String
body = LCase(mailitem.subject + " " + mailitem.body) 'Check subject and body
Dim i As Integer
For i = 0 To num
If InStr(body, awords(i)) > 0 Then 'Found a word, issue warning
Message_Add text_warn_attachment
Exit Sub
End If
Next i
End Sub
'----------------------------------------------------
'This checks domain forwarding
'----------------------------------------------------
Public Sub Check_Domain_Forward(mailitem As Outlook.mailitem)
If set_warning_domain_multiple Then Exit Sub 'Already warning about multiple domains, no need to warn about forwarding
If Not is_forward Then Exit Sub
If domain_safe Then Exit Sub
Message_Add text_warn_domain_forward + use_domain_safe + vbCrLf + recipient_list
End Sub
'----------------------------------------------------
'This checks sending to multiple domains
'----------------------------------------------------
Public Sub Check_Domain_Multiple(mailitem As Outlook.mailitem)
If domain_count < 2 Then Exit Sub
Message_Add text_warn_domain_multiple + vbCrLf + recipient_list
set_warning_domain_multiple = True 'Set warning that messages sent to mulitple domains, so do not set a similar message elsewhere
End Sub
'----------------------------------------------------
'Checks that subject is at least a minimum number of characters.
'Looks for the last colon and checks for a subject after that,
'in case of forwarding where you might have Re: Fwd:
'as the subject
'----------------------------------------------------
Public Sub Check_Subject(mailitem As Outlook.mailitem)
If subject_length >= property_minimum_subject_length Then Exit Sub
Dim m As String
If subject_colon Then
m = text_warn_subject_length_colon
Else
m = text_warn_subject_length
End If
Message_Add m + CStr(property_minimum_subject_length) + "."
End Sub
'----------------------------------------------------
Public Sub Extract_Domain(mailitem As Outlook.mailitem)
'----- Set from properties
Dim sep As String 'Separator
sep = text_sep 'Separator
'----- List of safe domains with separators so can look up easily
Dim domainssafe As String 'Safe domain
If use_domain_safe <> "" Then
domainssafe = sep + LCase(use_domain_safe) + sep
Else
domainssafe = ""
End If
'----- Working variables
Dim address As String 'Address
Dim count As Integer 'Number of domains
Dim domainsep As String 'For lookup
Dim domain As String 'Each domain name
Dim domains As String 'Domains sending to
Dim i As Integer 'Number of different domains
Dim k As Integer 'Position of @
Dim r As Recipient 'Each recipient
Dim recipientlist As String 'List of recipients
Dim recipients As Outlook.recipients
Dim safe As Boolean
count = 0 'Number of domains
domains = "" 'List of domains separated by comma
Set recipients = mailitem.recipients
recipientlist = "" 'Recipient list
safe = True 'All domains safe
For i = 1 To recipients.count
Set r = recipients.item(i) 'Get first item
address = r.address 'Get address
k = InStr(address, "@")
If k > 0 Then 'Is an email address
domain = LCase(Mid(address, k + 1)) 'Get domain
domainsep = sep + domain + sep 'For lookup
If InStr(sep + domains + sep, domainsep) = 0 Then 'New domain
count = count + 1 'Found a new domain
If domains <> "" Then domains = domains + sep
domains = domains + domain 'Add domain to list
If safe Then 'So far all domains safe, so check if new domain safe
If InStr(domainssafe, domainsep) = 0 Then safe = False 'Not safe
End If
If Len(recipientlist) Then recipientlist = recipientlist + text_sep_email
recipientlist = recipientlist + address
End If
End If
Next i
'---- Set properties
domain_count = count
domain_list = domains
recipient_list = recipientlist
domain_safe = safe
End Sub
'----------------------------------------------------
'Checks that subject is at least a minimum number of characters.
'Looks for the last colon and checks for a subject after that,
'in case of forwarding where you might have Re: Fwd:
'as the subject
'----------------------------------------------------
Public Sub Extract_Subject(mailitem As Outlook.mailitem)
'----- Set from properties
Dim sep As String 'Separator
sep = text_sep 'Separator
Dim subject As String
'----- Working variables
subject = mailitem.subject
subject = Trim(subject)
Dim l As Integer
Dim lensubject As Integer
lensubject = Len(subject)
'----- Check subject length after colon
Dim i As Integer
i = InStrRev(subject, ":")
'---- There is a colon
If i > 0 Then 'There is a colon
'----- Set length after colon
If i = lensubject Then
lensubject = 0
Else
lensubject = Len(Trim(Mid(subject, i + 1)))
End If
'----- Check for reply or forwarding
Dim w As String
i = InStr(subject, ":") 'Find first colon
w = LCase(Left(subject, i)) 'Get what starts subject line
If InStr(sep + use_forward_words, sep + w) Then
is_forward = True
ElseIf InStr(sep + use_reply_words, sep + w) Then
is_reply = True
End If
subject_colon = True
End If
subject_length = lensubject
End Sub
'----------------------------------------------------
'Returns: true to send message, false to not send message
'This is the main checking routine.
'The structure is organized for easily adding more checking routines.
'----------------------------------------------------
Public Function Item_Send_Check(mailitem As Outlook.mailitem) As Boolean
Extract_Domain mailitem
Extract_Subject mailitem
If property_check_domain_multiple Then Check_Domain_Multiple mailitem 'Check to see if sending to multiple domains
If property_check_domain_forward Then Check_Domain_Forward mailitem 'Check to see if forwarding a message to somewhere other than agtsi
If property_check_subject Then Check_Subject mailitem 'Check to see if subject blank
If property_check_attachment Then Check_Attachment mailitem 'Check for attachment
Item_Send_Check = Message_Send_Ask() 'Display message if needed
End Function
'----------------------------------------------------
'Adds text to the warning message.
'----------------------------------------------------
Public Sub Message_Add(text As String)
If text = "" Then Exit Sub
If message <> "" Then message = message + vbCrLf + vbCrLf 'Add two breaks to have full line separating
message = message + text
End Sub
'----------------------------------------------------
'The last thing the main checking routine does is call this procedure.
'This procedure checks to see if there is a warning message.
'If there is, it displays the message and checks the response.
'The question can be asked in either of two ways:
' 1. Do you want to send?
' 2. Do you want to cancel sending?
'The message_answer_yes property lets you choose which
'way you want the question asked so that when the sender
'clicks yes, you can either send or abort
'----------------------------------------------------
Public Function Message_Send_Ask()
Message_Send_Ask = True 'Send the email
If message = "" Then Exit Function 'No message to display
'----- Which message to display
If message_answer_yes Then
Message_Add text_send_message_now
Else
Message_Add text_send_message_abort
End If
'----- Display message
Dim yes As Boolean
yes = MsgBox(message, vbQuestion + vbYesNo + vbMsgBoxSetForeground) = vbYes 'How answered question
If yes <> message_answer_yes Then Message_Send_Ask = False 'If answer does not match how question asked, then the answer was do not send
End Function
'----------------------------------------------------
By Andrew Weitzen, Bronze Inc. (c) 2010
Bronze is the publisher of several online Internet journals including: InternetHandholding.com, DomainNames.gs, DotNetNuke.bz, Programmer.bz, Software.vg, WebHosting.vg