// This is the script to give summary on the main page.
Think IPM

Thursday, May 21, 2009


Aimage  pet peeve of mine is improper use of the CAPS LOCK key in emails.  Marcos Velez has written up a quick Outlook rule that will evaluate an incoming message and test to see if it is written in ALL CAPS.  If so, it will delete it and auto-respond to the user asking them to resend the message in proper Sentencing Case.  It has some checks in there too in order to verify that the message is of a certain length (to avoid OK, STFU, DOH messages).  Typical of Marcos’ code, it is fully commented and a great learning example as well. (Useful for those of us :Me: that hack together other peoples scripts to do my bidding.)  This script definitely highlights the power of Microsoft Outlook Rules.
The Code below will send back the following message :

Your message was automatically deleted.  This action was taken because the message was written using only capital letters.

If it is important that your message reach its intended recipient, please resend it using proper sentence casing.

Be sure to add this in as a Macro into Outlook : ALT-F11 (Tools –> Macros –> VB Editor)
Then set up your rule to RUN A SCRIPT :
 image  image
Here is the code :
Sub DeleteAllCAPS(MyMail As MailItem)
    ' First, we declare our variables.
    Dim strID As String
    Dim msgText As String
    Dim replySeparatorPosition As Integer
    Dim objMail As Outlook.MailItem
    ' The following code is a nifty way to get around the Outlook security prompts
    ' when macros or scripts are trying to interact with mail items
    strID = MyMail.EntryID
    Set objMail = Application.Session.GetItemFromID(strID)
    ' Retrieve the email message itself and store it in a variable
    msgText = objMail.Body
    ' Now, the fun starts...
    ' To ensure that we only evaluate the ORIGINAL message typed by the sender, we look for the
    ' "reply separator".  The problem is that different software packages use different separators.
    ' So, we will look for the two basic ones I see most often.  This will be updated regularly to
    ' include other types that I may come across.
    ' Here we look for the standard Outlook reply separator
    replySeparatorPosition = InStr(msgText, "_____ ")
    ' If we didnt find a reply separator above, we now look for the iPhone reply separator
    If (replySeparatorPosition = 0) Then
        replySeparatorPosition = InStr(1, msgText, "--- On ", vbBinaryCompare)
    End If
    ' If a reply separator was found, we assume that the original message starts at the first
    ' position and ends at the point where the reply separator starts.
    If (replySeparatorPosition > 1) Then
        msgText = Mid(msgText, 1, replySeparatorPosition - 1)
    End If
    ' Now, if the original message meets certain criteria, we reject it...!
    If ((UCase(msgText) = msgText) And (Len(msgText) > 4) And (hasLetters(msgText))) Then
        Dim origSender As String
        Dim replyMessage As String
        Dim objReply As Outlook.MailItem
        Set objReply = objMail.Reply
        replyMessage = "Your message was automatically deleted.  This action was taken because the message was written using only capital letters."
        replyMessage = replyMessage & vbCrLf & "If it is important that your message reach its intended recipient, please resend it using proper sentence casing."
        replyMessage = replyMessage & vbCrLf & vbCrLf & "--- YOUR ORIGINAL MESSAGE IS BELOW THIS LINE ---" & vbCrLf & objMail.Body
        objReply.Body = replyMessage
        objReply.BodyFormat = objMail.BodyFormat
        Set objReply = Nothing
    End If
    Set objMail = Nothing
End Sub
Function hasLetters(sourceString As String)
    Dim objRegEx As Object
    Dim matched As Boolean
    Dim Matches As Object
    matched = False
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .MultiLine = True
        .Global = True
        .Ignorecase = False
    End With
    objRegEx.Pattern = "[a-zA-Z]"
    Set Matches = objRegEx.Execute(sourceString)
    If (Matches.Count > 0) Then
        matched = True
    End If
    hasLetters = matched
End Function
blog comments powered by Disqus Blog Widget by LinkWithin