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

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

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 文档，它确实警告格式丢失，因此它可能是不可能的。谢谢

如果有关于属性 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 正文的电子邮件上尝试此宏。目的是发现 RTF 正文后面是否隐藏着良好的 Html 正文。如果有的话，我建议你尝试一下：

• 将 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