Microsoft Outlook Macro - check for missing attachments and bad words

From NoskeWiki
Jump to navigation Jump to search

About

NOTE: This page is a daughter page of: Microsoft Outlook and Macros


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:

  1. Open MS Outlook 2010
  2. Using the ribbon click: File >> Options
  3. Select Customize Ribbon on the left and then (if not already) tick "Developer" on the right > then OK.
  4. Click the "Developer" tab (which should now appear on the ribbon) and click "Visual Basic".
  5. In the VB window expand "Project1" and double-click "ThisOutlookSession"
  6. 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.
  7. 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


Links