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

我的exchange服务器空间有限，因此我希望将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和三种body格式的清晰文档，我从未发现过

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

我知道如果你修改HtmlBody，Outlook会修改Body以匹配。这不是一个非常复杂的修正案；据我所知，新的主体只是删除了所有Html标记的新HtmlBody

将正文格式从RTF更改为Html时会发生什么情况？Outlook是否会删除RTF正文，以便您看到错误的Html正文，而这些正文总是在幕后出现？Outlook是否尝试从RTF正文创建Html正文，这很糟糕？我不知道，但也许我们能找到答案

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

• 将Html正文保存为字符串
• 将正文格式更改为Html
• 清除RTF主体
• 从字符串还原Html正文

选项显式
子检查htmlbody（）
“从Kyle的答案中查找桌面的技术：
' http://stackoverflow.com/a/17551579/973283
Dim Exp作为Outlook.Explorer
变暗的inx和长的一样
将路径设置为字符串
Path=CreateObject（“WScript.Shell”）.SpecialFolders（“桌面”）
Set Exp=Outlook.Application.ActiveExplorer
如果Exp.Selection.Count=0，则
调试。打印“未选择电子邮件”
其他的
对于InxS=1到Exp.Selection.Count
使用Exp.Selection（InxS）
如果.HtmlBody“”则
调用PutTextFileUtf8（路径&“\TestHtml”&InxS&“.htm”、.HtmlBody）
如果结束
以
下一个
如果结束
端接头
公共子PutTextFileUtf8（ByVal PathFileName作为字符串，ByVal FileBody作为字符串）
'将FileBody输出为文本文件（UTF-8编码，无前导BOM）
'命名路径文件名
'需要参考“Microsoft ActiveX数据对象n.n对象库”
“我只测试了6.1版。
'2016年11月1日从http://stackoverflow.com/a/4461250/973283
'但将文字替换为参数
Dim BinaryStream作为对象
将UTFStream变暗为对象
设置UTFStream=CreateObject（“adodb.stream”）
UTFStream.Type=adTypeText
UTFStream.Mode=adModeReadWrite
UTFStream.Charset=“UTF-8”
UTFStream.LineSeparator=adLF
UTFStream.打开
UTFStream.WriteText文件体，adWriteLine
UTFStream.Position=3'跳过物料清单
Set BinaryStream=CreateObject（“adodb.stream”）
BinaryStream.Type=adTypeBinary
BinaryStream.Mode=adModeReadWrite
二进制流，打开
'条带BOM表（前3个字节）
UTFStream.CopyTo二进制流
UTFStream.Flush
UTFStream，关闭
设置UTFStream=Nothing
BinaryStream.SaveToFile路径文件名，adSaveCreateOverWrite
BinaryStream.Flush
二进制流。关闭
Set BinaryStream=Nothing
端接头

很抱歉耽误了我们的时间。使用上面的方法似乎可以将一个好的副本保存为一个html文件，因此我们似乎有很好的html可以使用。我尝试用

strHTML=.HTMLBody.BodyFormat=olFormatHTML.Body=strHTML.Close olSave替换PutTextFileUtf8调用，但最终我收到了一封html电子邮件，但将html显示为纯文本，包括标题和标记。可能丢失了一些东西。@Charlton你知道你有很好的html，所以一定有办法让它正确显示。我不知道我能帮什么忙。在我写这篇文章时，我刚刚注意到，你说的是
。Body=strHTML
而不是
。HTMLBody=strHTML
。您是否将保存好的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