This class is useful for checking email messages in Outlook before sending. This class checks these things.

1. Sending to more than one domain
2. Forwarding to a domain other than the safe domains
3. The subject line is not blank
4. Missing attachment

Initialize this class in the Application_SendItem event, change the properties to your preferences and then call the Item_Send_Check method.

See this Outlook Application_ItemSend implemetation for a complete example.

The code follows below. You can copy and paste this code into a new class module.

'----------------------------------------------------
'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(use_attach_words, ",")
    num = UBound(awords)
    If num < 0 Then Exit Sub 'No words to check
    Dim body As String
    body = 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 + 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 = 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