Outlook Macro for Checking Missing Attachments and More

gistfile1.txt

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