Microsoft Outlook 2003 Tip: VBA Macro to Remove Stationery from Email Message

Filed under Tips by adam | January 26, 2008 | 34 comments

Quick link to ClearStationery.bas

I don’t have much (any?) history of posting tips for the Windows platform, but I’m currently stuck with it for daily work use, so I figured I might as well share some tips that my readers who happen to be in the same predicament will find useful. (Planet Debian readers please have mercy.)

One of the worst things you that Microsoft Outlook allows a user to do is select a “stationery” for email. Stationery goes beyond regular old HTML mail (e.g., fonts, colors, and bullet lists) to add a patterned background, invariably rendering the content much less readable than it would be with a white (or even any other color) background. What’s worse is every reply to an email with stationery also adopts the original sender’s stationery!

I searched quite a bit for a solution that does not involve sending a nastygram to the original sender. Of course you can convert the email to plain text (or set Outlook to only display the plain text version) and then convert back to HTML or Rich Text, but you’ll also lose other formatting that you might want to retain. You could cut and paste the text into a new email, but what is really needed is a simple VBA macro that will strip the stationery but not other formatting.

Strangely, I don’t think that macro already exists. So I wrote one, to some extent cribbing from related code snippets (mostly from here). I now present to the world ClearStationery.bas, my best contribution to date to the Outlook ecosystem. Simply paste it into your Outlook Visual Basic Editor (ALT-F11) and then map the macro ClearStationeryFormatting() onto a toolbar with a hotkey, and you can instantly remove stationery from any email, whether it is in the “preview” pane or the full message view.

Comments, bug reports, and improvements are welcome:

Sub ClearStationeryFormatting()
On Error GoTo ClearStationeryFormatting_Error
    Dim strEmbeddedImageTag As String
    Dim strStyle As String
    Dim strReplaceThis As String
    Dim intX As Integer, intY As Integer
    Dim myMessage As Outlook.MailItem

    ' First, check to see if we are in preview-pane mode or message-view mode
    ' If neither, quit out
    Select Case TypeName(Outlook.Application.ActiveWindow)
        Case "Explorer"
            Set myMessage = ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set myMessage = ActiveInspector.CurrentItem
        Case Else
            MsgBox ("No message selected.")
            Exit Sub
    End Select

    ' Sanity check to make sure selected message is actually a mail item
    If TypeName(myMessage) <> "MailItem" Then
       MsgBox ("No message selected.")
       Exit Sub
    End If

    ' Remove attributes from <BODY> tag
    intX = InStr(1, myMessage.HTMLBody, "<BODY", vbTextCompare)
    If intX > 0 Then
        intY = InStr(intX, myMessage.HTMLBody, ">", vbTextCompare)
        strReplaceThis = Mid(myMessage.HTMLBody, intX, intY - intX + 1)
    End If

    If strReplaceThis <> "" Then
        myMessage.HTMLBody = Replace(myMessage.HTMLBody, strReplaceThis, "<BODY>")
        strReplaceThis = ""
    Else
        Err.Raise vbObjectError + 7, , "An unexpected error occurred searching for the BODY tag in the e-mail message."
        Exit Sub
    End If

    ' Find and replace <STYLE> tag
    intX = InStr(1, myMessage.HTMLBody, "<STYLE>", vbTextCompare)
    If intX > 0 Then
        intY = InStr(8, myMessage.HTMLBody, "</STYLE>", vbTextCompare)
        strReplaceThis = Mid(myMessage.HTMLBody, intX, ((intY + 8) - intX))
    End If

    If strReplaceThis <> "" Then
        myMessage.HTMLBody = Replace(myMessage.HTMLBody, strReplaceThis, "")
    End If

    If InStr(1, myMessage.HTMLBody, "<center><img id=", vbTextCompare) > 0 Then
        strEmbeddedImageTag = "<center><img id="
        '"<center><img id=""ridImg"" src="citbannA.gif align=bottom></center>"
        intX = InStr(1, myMessage.HTMLBody, strEmbeddedImageTag, vbTextCompare)
        If intX = 0 Then
            Err.Raise vbObjectError + 8, , "An unexpected error occurred searching for the embedded image file name start tag in the e-mail message."
            Exit Sub
        End If
        intY = InStr(intX + Len(strEmbeddedImageTag), myMessage.HTMLBody, " align=bottom></center>", vbTextCompare)
        If intY = 0 Then
            Err.Raise vbObjectError + 9, , "An unexpected error occurred searching for the embedded image file name end tag in the e-mail message."
            Exit Sub
        End If
        strEmbeddedImageTag = Mid(myMessage.HTMLBody, intX, intY - intX)
        intX = InStr(1, myMessage.HTMLBody, "<CENTER>", vbTextCompare)
        intY = InStr(intX, myMessage.HTMLBody, "</CENTER>", vbTextCompare)
        strReplaceThis = Mid(myMessage.HTMLBody, intX, intY - intX) & "</CENTER>"
        myMessage.HTMLBody = Replace(myMessage.HTMLBody, strReplaceThis, "", , , vbTextCompare)
    End If

    ' Finally, saved modified message
    myMessage.Save

    On Error GoTo 0
    Exit Sub

ClearStationeryFormatting_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
    Resume Next
End Sub

Stationery-B-Gone!