Outlook VBA convert Rich Text to HTML format

Question

I have limited space in my exchange server, so I want to convert all selected messages in my Outlook 2007 inbox to HTML format as they are smaller than their Rich Text format equivalents when images are involved. I have the following code which kind of does the job, but the formatting goes all over the place and the images become undreadable attachments, and the size doesn't change.

Public Sub ConvertHTML()

    Dim selItems As Selection
    Dim myItem As Object

' Set reference to the Selection.
    Set selItems = ActiveExplorer.Selection

' Loop through each item in the selection.
    For Each myItem In selItems
        myItem.Display
        myItem.BodyFormat = olFormatHTML
        myItem.Close olSave
    Next

    MsgBox "All Done. Email converted to HTML.", vbOKOnly, "Message"

    Set selItems = Nothing

End Sub

If I do it manually:- Open Rich Text email, Edit message, change to HTML, Save and close, then the formatting remains, the image stays embedded and the message size is reduced. How can I replicate this in VBA? I have checked the BodyFormat documentation and it does warn of formatting loss so it may just not be possible. thanks

Answer 1

If there is any clear documentation on property BodyFormat and the three body formats, I have never discovered it.

A MailItem has had properties Body and HtmlBody since Outlook 2003 and perhaps earlier. I can find no mention of property RTFBody before Outlook 2010. Most emails I have examined have both Body and HtmlBody. I have never seen a RTFBody. Outlook 2003 had the option of creating a RTF body but, apparently, no way of storing it other than as an Html body. I have never tried creating a RTF body because few of my friends use Outlook and I doubt their email packages support RTF.

I know that if you amend the HtmlBody, Outlook will amend Body to match. It is not a very sophisticated amendment; as far as I can tell, the new Body is just the new HtmlBody with all the Html tags removed.

What happens when you change the body format from RTF to Html? Does Outlook delete the RTF body so you see the faulty Html body that was always there behind the scenes? Does Outlook attempt, badly, to create an Html body from the RTF body? I do not know but perhaps we can find out.

The macro below saves Html bodies as Html files on the desktop. My browser displays those files perfectly. Please try this macro on some of your emails with RTF bodies. The objective is to discover if there is a good Html body hiding behind the RTF body. If there is, I suggest you try:

• Save the Html body to a string.
• Change body format to Html.
• Clear the RTF body.
• Restore the Html body from the string.

.

Option Explicit
Sub CheckHtmlBody()

  ' Technique for locating desktop from answer by Kyle:
  ' http://stackoverflow.com/a/17551579/973283

  Dim Exp As Outlook.Explorer
  Dim InxS As Long
  Dim Path As String

  Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Debug.Print "No emails selected"
  Else
    For InxS = 1 To Exp.Selection.Count
      With Exp.Selection(InxS)
        If .HtmlBody <> "" Then
          Call PutTextFileUtf8(Path & "\TestHtml" & InxS & ".htm", .HtmlBody)
        End If
      End With
    Next
  End If

End Sub
Public Sub PutTextFileUtf8(ByVal PathFileName As String, ByVal FileBody As String)

  ' Outputs FileBody as a text file (UTF-8 encoding without leading BOM)
  ' named PathFileName

  ' Needs reference to "Microsoft ActiveX Data Objects n.n Object Library"
  ' I have only tested with version 6.1.

  '  1Nov16  Copied from http://stackoverflow.com/a/4461250/973283
  '          but replaced literals with parameters

  Dim BinaryStream As Object
  Dim UTFStream As Object

  Set UTFStream = CreateObject("adodb.stream")

  UTFStream.Type = adTypeText
  UTFStream.Mode = adModeReadWrite
  UTFStream.Charset = "UTF-8"
  UTFStream.LineSeparator = adLF
  UTFStream.Open
  UTFStream.WriteText FileBody, adWriteLine

  UTFStream.Position = 3 'skip BOM

  Set BinaryStream = CreateObject("adodb.stream")
  BinaryStream.Type = adTypeBinary
  BinaryStream.Mode = adModeReadWrite
  BinaryStream.Open

   'Strips BOM (first 3 bytes)
  UTFStream.CopyTo BinaryStream

  UTFStream.Flush
  UTFStream.Close
  Set UTFStream = Nothing

  BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
  BinaryStream.Flush
  BinaryStream.Close
  Set BinaryStream = Nothing

End Sub