Be sure to add this in as a Macro into Outlook : ALT-F11 (Tools –> Macros –> VB Editor)
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
objReply.Send
objMail.Delete
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