Outlook VBA 将富文本转换为 HTML 格式

Question

我的 Exchange 服务器中的空间有限，因此我想将 Outlook 2007 收件箱中的所有选定邮件转换为 HTML 格式，因为当涉及图像时，它们比它们的 Rich Text 格式等效值小。我有以下代码可以完成这项工作，但是格式到处都是，图像变成不可读的附件，并且大小没有改变。

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

如果我手动执行此操作：- 打开富文本电子邮件、编辑消息、更改为 HTML、保存并关闭，然后格式保持不变，图像保持嵌入并且消息大小减小。如何在 VBA 中复制它？ 我检查了 BodyFormat 文档，它确实警告格式丢失，所以它可能是不可能的。谢谢

Answer 1

如果有关于属性 BodyFormat 和三种正文格式的明确文档，我从来没有发现过。

自 Outlook 2003 甚至更早的版本以来，MailItem 就具有 Body 和 HtmlBody 属性。在 Outlook 2010 之前，我找不到任何提及属性 RTFBody。我检查过的大多数电子邮件都有 Body 和 HtmlBody。我从未见过 RTFBody。 Outlook 2003 可以选择创建 RTF 正文，但显然，除了作为 Html 正文之外，没有其他方法可以存储它。我从未尝试过创建 RTF 正文，因为我的朋友很少使用 Outlook，而且我怀疑他们的电子邮件包是否支持 RTF。

我知道如果你修改 HtmlBody，Outlook 会修改 Body 来匹配。这不是一个非常复杂的修正案；据我所知，新的 Body 就是去掉了所有 Html 标签的新的 HtmlBody。

当您将正文格式从 RTF 更改为 Html 时会发生什么？ Outlook 是否会删除 RTF 正文，以便您看到始终存在于幕后的错误 Html 正文？ Outlook 是否会严重尝试从 RTF 正文创建 Html 正文？我不知道，但也许我们可以找到。

下面的宏将 Html 正文保存为桌面上的 Html 文件。我的浏览器完美地显示了这些文件。请在您的一些带有 RTF 正文的电子邮件上尝试此宏。目的是发现是否有一个好的 Html 正文隐藏在 RTF 正文后面。如果有的话，我建议你试试：

• 将 Html 正文保存为字符串。
• 将正文格式更改为 Html。
• 清除 RTF 正文。
• 从字符串中恢复 Html 正文。

.

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