vba 将富文本导出到 Outlook 并保持格式

Exporting rich text to outlook and keep formatting

提问by Magnus

I have a button in Access that opens Outlook, creating an appointment.

我在 Access 中有一个按钮可以打开 Outlook，创建约会。

Private Sub addAppointEstimate_Click()
    Dim objOutlook As Object
    Dim objOutLookApp As Object
    Dim strSubject As String
    Dim strBody As String

    strSubject = Forms!frmMain.LastName 'more stuff to add
    strBody = DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78") '& Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID)

    Set objOutlook = CreateObject("Outlook.Application")
    Set objOutLookApp = objOutlook.CreateItem(1)
    With objOutLookApp
        .subject = strSubject
        .RTFBody = StrConv(strBody, vbFromUnicode)
        .Display
    End With

End Sub

The problem is that I want to insert Rich text into the Body but it doesn't format correctly, as it shows all the HTML tags instead e.g:

问题是我想在正文中插入富文本，但格式不正确，因为它显示了所有 HTML 标签，例如：

<div><strong>example </strong><font color=red>text</font></div>

Is there a way I can send or convert the rich text to Outlook in a format it will recognise?(Maybe using the clipboard)

有没有一种方法可以将富文本发送或转换为 Outlook 可以识别的格式？（也许使用剪贴板）

It seems many people have solution for Excel, but I am struggling to get them to work in Access:

似乎很多人都有 Excel 的解决方案，但我很难让他们在 Access 中工作：

• HTML Text with tags to formatted text in an Excel cell

• http://dailydoseofexcel.com/archives/2005/02/23/html-in-cells-ii/

• 带有标记的 HTML 文本，用于 Excel 单元格中的格式化文本

• http://dailydoseofexcel.com/archives/2005/02/23/html-in-cells-ii/

采纳答案by Magnus

I came up with a solution. I have just copied and pasted the entire sub, but the answer is in there I promise. I have also highlighted the important bits.

我想出了一个解决方案。我刚刚复制并粘贴了整个子文件，但我保证答案就在那里。我还强调了重要的部分。

I works on my home machine, but not on the clients. So Icant use it, but if you can improve on it let me know.

我在我的家用机器上工作，但不在客户端上工作。所以我不能使用它，但如果你能改进它，请告诉我。

Private Sub addAppointmentEst_Click()


    Dim objOutlook As Object
    Dim objOutLookApp As Object
    Dim strSubject As String
    Dim strBody As String

    On Error GoTo appointmentEstError

    If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
        DoCmd.OpenForm "frmEditEstimate", , , , , acHidden '<------ OPEN FORMATTED TEXT IN A FORM
        Forms!frmEditEstimate.SetFocus
        Forms!frmEditEstimate!frmSubEstimateItems.Form.EstimateText.SetFocus
        DoCmd.RunCommand acCmdCopy '<------ COPY FORMATTED TEXT
        DoCmd.Close acForm, "frmEditEstimate", acSaveNo
    End If

'        If Not IsNull(Forms!frmMain.Title.Value) Then
'            strSubject = strSubject & Forms!frmMain.Title.Value
'        End If
     If Not IsNull(Forms!frmMain.FirstName.Value) Then
         strSubject = strSubject & Forms!frmMain.FirstName.Value
    End If
    If Not IsNull(Forms!frmMain.LastName.Value) Then
        strSubject = strSubject & " " & Forms!frmMain.LastName.Value
    End If
    If Not IsNull(Forms!frmMain.Organisation.Value) Then
        strSubject = strSubject & " (" & Forms!frmMain.Organisation.Value & ")"
    End If
    If Not IsNull(Forms!frmMain!frmSubTransaction.Form.Property.Value) Then
        strSubject = strSubject & " - " & Forms!frmMain!frmSubTransaction.Form.Property.Value
    End If

    Set objOutlook = CreateObject("Outlook.Application")
    Set objOutLookApp = objOutlook.CreateItem(1)

     With objOutLookApp
         .subject = strSubject
         .Display
     End With

    If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
        Set objectOutlookBody = objOutlook.ActiveInspector.WordEditor
        objOutLookApp.Body = vbCrLf & "Estimate ID: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID.Value & _
                            vbCrLf & "Estimate Date: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateDate.Value
        objectOutlookBody.Application.Selection.Paste '<----- PASTE TEXT INTO APPOINTMENT

        Forms!frmMain.EmptyValue.Value = " " '<----- EMPTY CLIPBOARD
        Forms!frmMain.EmptyValue.SetFocus
        DoCmd.RunCommand acCmdCopy
    End If

Exit Sub

appointmentEstError:
        MsgBox _
        Prompt:="Failed create an appointment in Outlook, with the estimate attached", _
        Buttons:=vbOKOnly + vbExclamation, _
        Title:="Error"
End Sub

回答by eddypi

To pass RTF formatted string to outlook email body is simple as following

将 RTF 格式的字符串传递给 Outlook 电子邮件正文很简单，如下所示

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)

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

The secret is not to use ".RTFBody" but just ".Body" and pass to it byte array as in the code above. It took me awhile to figure it out. Thanks to Microsoft we always will have something to figure out.

秘诀是不使用“.RTFBody”而只使用“.Body”并将字节数组传递给它，如上面的代码所示。我花了一段时间才弄明白。多亏了微软，我们总能找到一些东西。

回答by AjimOthy

You can use a little extra overhead to create a message with the formatted HTMLBody content, then copy the content to an Appointment item.

您可以使用一些额外的开销来使用格式化的 HTMLBody 内容创建消息，然后将内容复制到约会项目。

Start by creating a message and an appointment and populating them as desired. Put the body text in the message, skip the body in the appointment for now.

首先创建一条消息和一个约会，并根据需要填充它们。将正文放在消息中，暂时跳过约会中的正文。

Dim objOutlook As Object
Dim objMyMsgItem As Object
Dim objMyApptItem As Object
Dim strSubject As String

strSubject = "Some text" 'Forms!frmMain.LastName 'more stuff to add

Set objOutlook = CreateObject("Outlook.Application")
Set objMyMsgItem = objOutlook.CreateItem(0) 'Message Item
With objMyMsgItem
    .HTMLBody = "<div><strong>example </strong><font color=red>text</font></div>"
            'DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78")
    .Display
End With

Set objMyApptItem = objOutlook.CreateItem(1) 'Appointment Item
With objMyApptItem
    .Subject = strSubject
    .Display
End With

Then use the GetInspector property to interact with the body of each item via a Word editor, and copy the formatted text that way.

然后使用 GetInspector 属性通过 Word 编辑器与每个项目的正文进行交互，并以这种方式复制格式化文本。

Dim MyMsgInspector As Object
Dim wdDoc_Msg As Object
Set MyMsgInspector = objMyMsgItem.GetInspector
Set wdDoc_Msg = MyMsgInspector.WordEditor

Dim MyApptInspector As Object
Dim wdDoc_Appt As Object
Set MyApptInspector = objMyApptItem.GetInspector
Set wdDoc_Appt = MyApptInspector.WordEditor

wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText

This code is tested and works in Access 2013.

此代码经过测试并在 Access 2013 中有效。

回答by T800

As in previous answer, this line is the key, it copies text, hyperlinks, pictures etc. without modifying clipboard content:

和之前的答案一样，这一行是关键，它复制文本、超链接、图片等，而不修改剪贴板内容：

wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText

回答by Dmitry Streblechenko

You are setting the plain text Body property. Set the HTMLBody property to a properly formatted HTML string.

您正在设置纯文本 Body 属性。将 HTMLBody 属性设置为格式正确的 HTML 字符串。