TAKE A STAND AGAINST ALL CAPS EMAILS …
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.
— YOUR ORIGINAL MESSAGE IS BELOW THIS LINE —
THIS IS A SAMPLE MESSAGE OF ALL CAPS.
Sub DeleteAllCAPS(MyMail As MailItem)'' First, we declare our variables.'Dim strID As StringDim msgText As StringDim replySeparatorPosition As IntegerDim 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.EntryIDSet 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) ThenreplySeparatorPosition = 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) ThenmsgText = 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))) ThenDim origSender As StringDim replyMessage As StringDim objReply As Outlook.MailItemSet objReply = objMail.ReplyreplyMessage = "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.BodyobjReply.Body = replyMessageobjReply.BodyFormat = objMail.BodyFormatobjReply.SendobjMail.DeleteSet objReply = NothingEnd IfSet objMail = NothingEnd SubFunction hasLetters(sourceString As String)Dim objRegEx As ObjectDim matched As BooleanDim Matches As Objectmatched = FalseSet objRegEx = CreateObject("VBScript.RegExp")With objRegEx.MultiLine = True.Global = True.Ignorecase = FalseEnd WithobjRegEx.Pattern = "[a-zA-Z]"Set Matches = objRegEx.Execute(sourceString)If (Matches.Count > 0) Thenmatched = TrueEnd IfhasLetters = matchedEnd Function