将 HTML 格式的文本获取到 Outlook 约会正文

Question

我发现 HTML 不是 AppointmentItem 对象中的选项。

然后我用用户的代码找到了以下答案PGilm（https://stackoverflow.com/a/34666267/18290219）

Dim oApp As Object
Dim oMail As Object

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(1)

With oMail
    .Subject = ""
    .Location = ""
    '.Start =
    '.Duration =
    ' .body = " < not formattable text >"
    .display
End With

Dim objItem As Object
Dim objInsp As Outlook.Inspector
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection

Set objItem = oMail ' Application.ActiveInspector.currentItem
Set objInsp = objItem.GetInspector
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection

objSel.PasteAndFormat (wdFormatOriginalFormatting)
'objSel.PasteAndFormat (Word.WdRecoveryType.wdFormatOriginalFormatting)

Set objItem = Nothing
Set objInsp = Nothing
Set objDoc = Nothing
Set objWord = Nothing
Set objSel = Nothing

Set oApp = Nothing
Set oMail = Nothing

我的 html 格式文本存储在名为“messages”的字符串中。如何将其保存到剪贴板以将其粘贴到会议中？

Answer 1

我已将您问题的起始行转换为 html（在 http://hilite.me/ 的帮助下）。

如果您将 HTML 消息保存在 html 模板中（例如使用记事本），则可以使用 Excel 打开它。 （您可以在这里找到一个非常基本的 html 模板 => https://www.w3schools.com/html/html_basic.asp）

在 Excel 中设置格式化文本后，您可以将其复制到 AppointmentItem（基于此处介绍的解决方法OlAppointment 对象的 HTMLBody 解决方法？:

Sub MakeApptWithRangeBody()

'!!!  ADD Reference to Microsoft Outlook Library
'
'     e.g.
'---> MENU ---> Tools ---> References
'--->   Microsoft Outlook 16.0 Object Library

Dim olApp As Outlook.Application
Dim olApt As Outlook.AppointmentItem

Const wdPASTERTF As Long = 1

Set olApp = Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)

Dim myTable As ListObject
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$A$15"), , _
    xlNo).Name = "myTable"
Set myTable = ActiveSheet.ListObjects(1)
myTable.TableStyle = None

With olApt
    .Start = Now + 1
    .End = Now + 1.2
    .Subject = "Test Appointment"
    myTable.Range.Copy
    .Display
    .GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With
Stop

Set olApt = Nothing
Set olApp = Nothing

End Sub

并且您的 html 显示在 AppointmentItem 中：

Answer 2

如果将 html 格式的文本复制到 MS Word，则可以将文档保存为 RTF 格式。您可以将此 rtf 文档重命名为 .txt 并将 rtf 编码添加到 vba 编辑器，或者使用 vba 读取该文件。

基于此处的建议：将富文本导出到 Outlook 并保持格式

Sub OpenAppointment()
Dim myRtfString As String

myRtfString = Get_RTF_Text
Call RTF2Outlook(myRtfString)

End Sub


Function RTF2Outlook(strRTF As String) As Boolean
    Dim myOlApp, myOlItem
    Dim arrFiles() As String, arrDesc() As String, i As Long

    Set myOlApp = CreateObject("Outlook.Application")
    'Set myOlItem = myOlApp.CreateItem(olMailItem)
    Set myOlItem = myOlApp.CreateItem(olAppointmentItem)

    With myOlItem
       .BodyFormat = olFormatRichText
       .Body = StrConv(strRTF, vbFromUnicode) 'Convert RTF string to byte array
    End With
    
    myOlItem.Display
    Stop
    
    Set myOlApp = Nothing
    Set myOlItem = Nothing
End Function

Function Get_RTF_Text()

Dim myString As String

myString = "{\rtf1\adeflang1025\ansi\ansicpg1252\uc1\adeff0\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe2052\themelang1033\themelangfe0\themelangcs0{\fonttbl{\f0\fbidi \froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f2\fbidi \fmodern\fcharset0\fprq1{\*\panose 02070309020205020404}Courier New;}"
myString = myString & "{\f34\fbidi \froman\fcharset0\fprq2{\*\panose 02040503050406030204}Cambria Math;}{\f36\fbidi \fnil\fcharset134\fprq2{\*\panose 02010600030101010101}DengXian{\*\falt \'b5\'c8\'cf\'df};}"
myString = myString & "{\f44\fbidi \froman\fcharset0\fprq0{\*\panose 020b0609020204030204}Consolas;}{\f45\fbidi \fnil\fcharset134\fprq2{\*\panose 02010600030101010101}@DengXian;}{\flomajor\f31500\fbidi \froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}"
myString = myString & "{\fdbmajor\f31501\fbidi \fnil\fcharset134\fprq2{\*\panose 02010600030101010101}DengXian Light{\*\falt \'b5\'c8\'cf\'df Light};}{\fhimajor\f31502\fbidi \fswiss\fcharset0\fprq2{\*\panose 020f0302020204030204}Calibri Light;}"
myString = myString & "{\fbimajor\f31503\fbidi \froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\flominor\f31504\fbidi \froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}"
myString = myString & "{\fdbminor\f31505\fbidi \fnil\fcharset134\fprq2{\*\panose 02010600030101010101}DengXian{\*\falt \'b5\'c8\'cf\'df};}{\fhiminor\f31506\fbidi \fswiss\fcharset0\fprq2{\*\panose 020f0502020204030204}Calibri;}"
myString = myString & "{\fbiminor\f31507\fbidi \froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f46\fbidi \froman\fcharset238\fprq2 Times New Roman CE;}{\f47\fbidi \froman\fcharset204\fprq2 Times New Roman Cyr;}"
myString = myString & "{\f49\fbidi \froman\fcharset161\fprq2 Times New Roman Greek;}{\f50\fbidi \froman\fcharset162\fprq2 Times New Roman Tur;}{\f51\fbidi \froman\fcharset177\fprq2 Times New Roman (Hebrew);}{\f52\fbidi \froman\fcharset178\fprq2 Times New Roman (Arabic);}"
'...
'...
myString = myString & "\ltrch\fcs0 \b\cf20\insrsid8334471 \hich\af2\dbch\af31505\loch\f2 Object}{\rtlch\fcs1 \af2 \ltrch\fcs0 \insrsid8334471 "
myString = myString & "\par }{\rtlch\fcs1 \ab\af2 \ltrch\fcs0 \b\cf19\insrsid8334471 \hich\af2\dbch\af31505\loch\f2 Dim}{\rtlch\fcs1 \af2 \ltrch\fcs0 \insrsid8334471 \hich\af2\dbch\af31505\loch\f2  oMail           }{\rtlch\fcs1 \ab\af2 \ltrch\fcs0 \b\cf1\insrsid8334471 "
myString = myString & "\hich\af2\dbch\af31505\loch\f2 As}{\rtlch\fcs1 \af2 \ltrch\fcs0 \insrsid8334471 \hich\af2\dbch\af31505\loch\f2  }{\rtlch\fcs1 \ab\af2 \ltrch\fcs0 \b\cf20\insrsid8334471 \hich\af2\dbch\af31505\loch\f2 Object}{\rtlch\fcs1 \af2 \ltrch\fcs0 \insrsid8334471 "

Get_RTF_Text = myString

End Function

结果如下所示：