Microsoft Outlook Macro - check for missing attachments and bad words
Contents
About
The Visual Basic (VB) Macro below is works with Microsoft Outlook 2010 and is related to an idea I had called called "Idea: NoMoreRegrettedEmails - an email plugin to help prevent mistakes and improve diplomacy". When you write an new e-mail and click "send", what this code does is to first check:
- (1) for missing attachments (as indicated if you use the word "attach", but have no attachments)
- (2) if may have accidentally clicked "reply all" (as indicated by multiple recipients)
- (3) if you are replying to a mailing list (as indicated by certain likely words in their addresses)
- (4) if you have typed bad/nasty words (as checked against a long list of potentially bad words)
If any of the following are true, you will see a warning message and have a chance to cancel the e-mail to fix these potential mistakes. The idea here is to give you that little chance to cancel and e-mail which you may "regret" sending to the wrong person, or saying the wrong thing. If you have good diplomacy, you'll know you should never say negative things, but for people without good diplomacy the hope is to catch a mistake before it happens.
Installing this Macro
This Macro applies to an "Application_ItemSend" even in Outlook, and as such you can't create it like a normal Macro. Below are the instructions on how to add this Macro. The instructions come directly from this brilliant article "How to Automatically BCC in Outlook 2010", which also includes pictures if you have any troubles with my text version:
- Open MS Outlook 2010
- Using the ribbon click: File >> Options
- Select Customize Ribbon on the left and then (if not already) tick "Developer" on the right > then OK.
- Click the "Developer" tab (which should now appear on the ribbon) and click "Visual Basic".
- In the VB window expand "Project1" and double-click "ThisOutlookSession"
- In the code editor window, choose "Application" from the drop-down menu in the top-left then "ItemSend" from the drop-down on the right.
- Add the code below and don't forget to then save your changes (save icon) and then test.
Outlook Macro for Checking Missing Attachments
To start simple, this code JUST checks for missing attachments, as this a very common thing to do. If interested in a more complex example use the example below instead.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'## CHECK IF ITEM IS NEW E-MAIL BEFORE PROCEEDING:
If (Item.Class <> olMail) Then Exit Sub ' Ensure this is a mail message and not a task or other "item".
If (Item.Recipients.Count = 0) Then Exit Sub ' Exit early if there are no recipients.
'## CHECK FOR MISSING ATTACHMENT:
Dim mailContent As String
Dim pos As Integer
mailContent = Item.Body + Item.Subject ' Get a copy of all the e-mail body text and subject text to search.
mailContent = LCase(mailContent) ' Make whole string lowercase for easier searching.
If (Item.Attachments.Count = 0) Then ' If there are no attachments:
pos = InStr(1, mailContent, "attach")
If (pos > 0) Then ' If the word 'attach' appears:
If (Not MsgYesNo("You have used the word 'attach', but there is no attached file." & vbNewLine & _
"Do you wish to ignore this and send anyway?")) Then
Cancel = True
Exit Sub
End If
End If
End If
End Sub
Outlook Macro for Checking Missing Attachments and Much More
As explained above, this next Macro makes multiple checks, including a check to see if swear words or negative words are used.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'## CHECK IF ITEM IS NEW E-MAIL BEFORE PROCEEDING:
If (Item.Class <> olMail) Then Exit Sub ' Ensure this is a mail message and not a task or other "item".
If (Item.Recipients.Count = 0) Then Exit Sub ' Exit early if there are no recpients.
'------------------------------
'## (1) CHECK FOR MISSING ATTACHMENT:
Dim mailContent As String
Dim pos As Integer
mailContent = Item.Body + Item.Subject ' Get a copy of all the e-mail body text and subject text to search.
mailContent = LCase(mailContent) ' Make whole string lowercase for easier searching.
' NOTE: different version of VB may want 'mailContent.ToLower()'.
If (Item.Attachments.Count = 0) Then ' If there are no attachments:
pos = InStr(1, mailContent, "attach")
If (pos > 0) Then ' If the word 'attach' appears:
If (Not MsgYesNo("You have used the word 'attach', but there is no attached file." & vbNewLine & _
"Do you wish to ignore this and send anyway?")) Then
Cancel = True
Exit Sub
End If
End If
End If
'------------------------------
'## (2) PROTECT AGAINST "REPLY ALL" MISTAKE
'## ... WARN USER IF MORE THAN ONE RECIPIENT:
Dim nRecipients As Integer ' Will store the number of recipients.
Dim isReply As Boolean ' Set to true if this looks like a reply (starts with "RE:").
nRecipients = Item.Recipients.Count
pos = InStr(1, Item.Subject, "RE:")
isReply = (pos > 0) And (pos < 2)
If (nRecipients > 1) Then ' If more than one recipient: show warning.
If (isReply) Then ' If it looks like a reply:
If (Not MsgYesNo("Are you sure you want to reply to" & vbNewLine & _
" " & nRecipients & " recipients")) Then
Cancel = True
MsgBox ("Message cancelled")
Exit Sub
End If
Else
If (Not MsgYesNo("Are you sure you want to send to " & nRecipients & " recipients")) Then
Cancel = True
Exit Sub
End If
End If
End If
'------------------------------
'## (3) PROTECT AGAINST "REPLY TO MAILING LIST" MISTAKE:
'## ... CHECK FOR LIKELY MAILING LIST TERMS IN RECIPIENT E-MAIL ADDRESSES
If (isReply) Then
Dim emailAddr, mlSuspectAddr, mlSuspects As String ' Used to record suspected "mailing list" email addresses.
Dim nLikelyMLAddr As Integer ' Used to tally the number of suspects found.
mlSuspects = ""
nLikelyMLAddr = 0
For i = 1 To Item.Recipients.Count ' For each recipent:
emailAddr = LCase(Item.Recipients(i).Address)
If (CountOccurances(emailAddr, "list", False) > 0 Or _
CountOccurances(emailAddr, "info", False) > 0 Or _
CountOccurances(emailAddr, "group", False) > 0 Or _
CountOccurances(emailAddr, "staff", False) > 0 Or _
CountOccurances(emailAddr, "students", False) > 0 Or _
CountOccurances(emailAddr, "employee", False)) Then ' If address contains any suspect terms:
nLikelyMLAddr = nLikelyMLAddr + 1 ' Increase the number of suspected mailing list addresses.
mlSuspectAddr = emailAddr ' Record this address.
If (nLikelyMLAddr < 10) Then ' Record the first ten suspects.
mlSuspects = mlSuspects + " > " + emailAddr + vbNewLine
End If
MsgBox (emailAddr & " " & nLikelyMLAddr)
End If
Next i
If (nLikelyMLAddr = 1) Then
If (Not MsgYesNo("The e-mail address '" & mlSuspectAddr & _
"' may be a mailing list with many recipients." & vbNewLine & _
"Are you sure you want to send?")) Then
Cancel = True
Exit Sub
End If
ElseIf (nLikelyMLAddr >= 2) Then
If (Not MsgYesNo(nLikelyMLAddr & " of your recipients may be mailing lists." & vbNewLine & vbNewLine & _
"These suspected mailing list addresses include: " & vbNewLine & _
mlSuspects & vbNewLine & vbNewLine & _
"Send anyway?")) Then
Cancel = True
Exit Sub
End If
End If
End If
'------------------------------
'## (4) CHECK FOR OFFENSIVE AND/OR POTENTIALLY AGRESSIVE WORDS:
If (PromptForNegativeWords(Item.Body, Item.Subject)) Then
Cancel = True
Exit Sub
End If
'## TEMPORARY OPTION TO CANCEL E-MAIL:
If (Not MsgYesNo("Would you really like to send this message")) Then
Cancel = True
MsgBox ("Message was cancelled")
End If
End Sub
'-------------------------------------------
' Inputs two strings, combines them and searches for a long list of "swearwords"
' and "negativewords". If any swear words and/or a high fraction of negative words
' are found, the user is presented with a summary and asked if he wants to change
' the e-mail before sending. If the user answers "yes" the function returns true.
' If the user answers "no" or there are no negative words found the function returns false.
' NOTE: Most of the swear words are from: "http://www.noswearing.com/dictionary/"
' and most of the negative words from: "http://eqi.org/fw_neg.htm"
' but feel free to add your own words you wish to check for.
'
Public Function PromptForNegativeWords(ByVal mailBody As String, ByVal headerBody As String) As Boolean
Dim contents As String
mailBody = LCase(mailBody)
headerBody = LCase(headerBody)
contents = mailBody + headerBody
'## LIST OF SWEAR WORD (WORDS WHICH ARE RUDE OR INSULTING):
Dim swearwords(0 To 186) As String
swearwords(0) = "aXXXnuXXXs" ' Swear word.
swearwords(1) = "aXXXrsXXXe" ' Swear word.
'.... REMOVE THE XXX's AND THEN ADD EXTRA WORDS HERE - SEE INSTRUCTIONS AT BOTTOM OF THIS PAGE.
swearwords(186) = "wXXXoXXXp" ' Racial slur.
'## LIST OF POTENTIALLY NEGATIVE WORDS:
Dim negativewords(0 To 783) As String
negativewords(1) = "abandon" ' Negative (potentially).
negativewords(2) = "abandoned" ' Negative (potentially).
negativewords(3) = "abuse" ' Negative.
negativewords(4) = "accusation" ' Negative.
'.... I'VE CUT THIS LIST SHORT, BUT HAVE A LONG LIST OF BAD WORDS AT THE BOTTOM OF THIS PAGE.
negativewords(782) = "zoilism" ' Negative.
negativewords(783) = "zombie" ' Insult (potentially).
'## TALLY SWEAR WORDS:
Dim swearWordList As String
Dim nSwearWords, nOccur As Integer
nSwearWords = 0
For i = 0 To 186
nOccur = CountOccurances(mailBody, swearwords(i), True)
If (nOccur > 0) Then
nSwearWords = nSwearWords + 1
If (nSwearWords <= 10) Then
swearWordList = swearWordList + " > " + str(nOccur) + " x " + swearwords(i) + vbNewLine
End If
End If
Next i
'## TALLY POTENTIALLY NEGATIVE WORDS:
Dim negWordList As String
Dim nNegWords As Integer
nNegWords = 0
For i = 1 To 783
nOccur = CountOccurances(mailBody, negativewords(i), True)
If (nOccur > 0) Then
nNegWords = nNegWords + 1
If (nNegWords <= 10) Then
negWordList = negWordList + " > " + str(nOccur) + " x " + negativewords(i) + vbNewLine
End If
End If
Next i
'## SHOW RESULTS OF ANALYSIS AND PROMPT USER FOR DECISION:
Dim nFlaggedWords As Integer
Dim msgString As String
Dim cancelMessage As Boolean
cancelMessage = False
nFlaggedWords = nSwearWords + nNegWords
If (nFlaggedWords > 0) Then ' If flagged words were found:
msgString = msgString + "A total of " + str(nFlaggedWords) + " flagged words were found..." + vbNewLine + vbNewLine
If (nSwearWords > 0) Then
msgString = msgString + "> " + str(nSwearWords) + " swear words including:" + vbNewLine + _
swearWordList + vbNewLine + vbNewLine
End If
If (nNegWords > 0) Then
msgString = msgString + "> " + str(nNegWords) + " negative words including:" + vbNewLine + _
negWordList + vbNewLine + vbNewLine
End If
If (Not MsgYesNo(msgString + "Do you wish to send the e-mail anyway?")) Then
cancelMessage = True
End If
End If
PromptForNegativeWords = cancelMessage
End Function
'-------------------------------------------
' Counts all occurences of "needle" in "haystack" and returns this as an integer.
' If "wholeWordsOnly" is true it will also check that the character before and after
' each occurance and if either contain a letter then this occurance is not counted -
' for intstance "CountOccurances("The antlion roars", "lion", True) will return 0 since
' "lion" is part of a larger word.
'
Public Function CountOccurances(ByVal haystack As String, ByVal needle As String, _
ByVal wholeWordsOnly As Boolean) As Integer
Dim pos, start, needleLen, numFound As Integer
numFound = 0
needleLen = Len(needle)
pos = InStr(haystack, needle)
Do While pos
numFound = numFound + 1
pos = InStr(pos + needleLen, haystack, needle)
If (wholeWordsOnly) Then
If (IsLowercaseLetter(haystack, pos - 1)) Then
numFound = numFound - 1
ElseIf (IsLowercaseLetter(haystack, pos + needleLen)) Then
numFound = numFound - 1
End If
End If
Loop
CountOccurances = numFound
End Function
'-------------------------------------------
' Returns true if the character at the given position (pos) within
' the given string (str) is a lowercase letter between a and z.
' If the given position does not exist or is a non letter it returns false.
'
Public Function IsLowercaseLetter(ByRef str As String, ByVal pos As Integer) As Boolean
If (pos < 1) Or (pos > Len(str) + 1) Then
IsLowercaseLetter = False
Exit Function
End If
Dim sChar As String * 1 ' There is no "Char" type in VB6, but this says a string of length 1.
sChar = Mid(str, pos, 1)
IsLowercaseLetter = (sChar >= "a") And (sChar <= "z")
End Function
'-------------------------------------------
' Displays an yes/no message and returns true if the user clicks "yes"
'
Public Function MsgYesNo(ByVal message As String) As Boolean
Dim answer As Integer
answer = MsgBox(message, vbYesNo, "Alert")
MsgYesNo = (answer = vbYes)
End Function
Obtaining a full list of bad words
In the code above I've truncated the list of bad words because (a) it would makes this page way too long and (b) it would make this page flagged as bad! If you want a full list of bad words I have the full code in a zip file, plus a spreadsheet which will allow you to add your own words [here].
See Also
- Microsoft Excel
- Idea: NoMoreRegrettedEmails - an email plugin to help prevent mistakes and improve diplomacy - explains why I wrote this code, and where I was hoping to go with it!
Links
- How to Automatically BCC in Outlook 2010 - great article which helped me get this far. :)