Note: newer code for the Application_Item_Send event is here.

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. The subject line is not blank
3. 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.

'----------------------------------------------------
'Properties you can change to your own liking
'----------------------------------------------------
Dim message As String 'Message to display in message box
Dim message_answer_yes As Boolean 'True for yes means send, false for yes means cancel
Dim property_check_attachment As Boolean
Dim property_check_domains_multiple As Boolean
Dim property_check_subject As Boolean
Dim property_minimum_subject_length As Integer
Dim text_attach_words As String 'Words to look for attachment
Dim text_send_message_abort As String 'Ask not send email
Dim text_send_message_now As String 'Ask to send email
Dim text_sep_email As String 'Separate email addresses
Dim text_warn_attachment As String
Dim text_warn_domains_multiple As String
Dim text_warn_subject_length As String
Dim text_warn_subject_length_colon As String
'----------------------------------------------------
'Initialize properties when class is initialized
'----------------------------------------------------
Private Sub Class_Initialize()
  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_domains_multiple = True 'Initialize to check for multiple domains
  property_check_subject = True 'Check subject line
  property_minimum_subject_length = 3 'Minimum length to avoid message
  text_attach_words = "attach,enclos" 'Words to look for attachment
  text_send_message_abort = "Edit message now and do not send?"
  text_send_message_now = "Send message now anyway?"
  text_sep_email = ", "
  text_warn_attachment = "Warning, no attachment"
  text_warn_domains_multiple = "Warning, sending to multiple domains "
  text_warn_subject_length = "Warning, subject too short, minimum number of characters is "
  text_warn_subject_length_colon = "Warning, subject too short, minimum number of characters after last colon is "
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_Message(mailitem As Outlook.mailitem)
    Dim num
    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(text_attach_words, ",")
    num = UBound(awords)
    If num < 0 Then Exit Sub 'No words to check
    Dim body
    body = mailitem.subject + " " + mailitem.body 'Check subject and body
    Dim i
    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
'----------------------------------------------------
'Args:
'  rlist = output set to list of recipients separated by comma
'Returns: true if more than one domain being sent to
'
'Check the destination email addresses. If sending to more
'than one domain, warn the sender.
'----------------------------------------------------
Public Function Check_Domains_Multiple(mailitem As Outlook.mailitem, rlist As String) As Boolean
    Dim multiple As Boolean
    Dim a$ 'Address
    Dim d$ 'Each domain name
    Dim d1$ 'First domain name
    Dim k 'Position of @
    Dim r As Recipient 'Each recipient
    Dim recipients As Outlook.recipients
    Set recipients = mailitem.recipients
    multiple = False
    For i = 1 To recipients.Count
        Set r = recipients.item(i)
        a$ = r.Address
        k = InStr(a$, "@")
        If k Then 'Is an email address
            If Not multiple Then 'See if condition met
                d$ = Mid$(a$, k + 1) 'Get domain
                If i = 1 Then 'Save first one to see if any others different
                    d1$ = d$
                Else
                    If d1$ <> d$ Then multiple = True 'A second domain exists
                End If
            End If
            If Len(rlist) Then rlist = rlist + text_sep_email
            rlist = rlist + a$
        End If
    Next i
    Check_Domains_Multiple = multiple
End Function
'----------------------------------------------------
'This separates the checking of multiple domains
'from adding the error message.
'This is just an example of one way to keep these
'functions separate so they could be used in other ways.
'The other checking routines, keep the message in the checking routine.
'----------------------------------------------------
Public Sub Check_Domains_Multiple_Message(mailitem As Outlook.mailitem)
    Dim rlist As String
    If Check_Domains_Multiple(mailitem, rlist) Then
        Message_Add text_warn_domains_multiple + vbCrLf + rlist
    End If
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_Message(mailitem As Outlook.mailitem)
    Dim subject As String
    subject = mailitem.subject
    subject = Trim(subject)
    '----- Check subject length
    Dim l
    l = Len(subject)
    Dim m
    m = property_minimum_subject_length
    If l < m Then
        Message_Add text_warn_subject_length + CStr(m)
        Exit Sub
    End If
    Dim i
    i = InStrRev(subject, ":")
    If i > 0 Then
        m = m + 1 'Account for a space after the colon
        If (l - i) < m Then
            Message_Add text_warn_subject_length_colon + CStr(m)
            Exit Sub
        End If
    End If
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
    If property_check_domains_multiple Then Check_Domains_Multiple_Message mailitem 'Check to see if sending to multiple domains
    If property_check_subject Then Check_Subject_Message mailitem 'Check to see if subject blank
    If property_check_attachment Then Check_Attachment_Message 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