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

Question

我在 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

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

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

有没有办法可以将富文本以 Outlook 可以识别的格式发送或转换到 Outlook？（可能使用剪贴板）

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

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

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

Answer 1

将 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

秘诀是不要使用“.RTFBody”，而只是使用“.Body”并将字节数组传递给它，就像上面的代码一样。我花了一段时间才弄清楚。 感谢微软，我们总能找到一些东西。

Answer 2

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

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

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

然后使用 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

此代码经过测试，可在 Access 2013 中使用。

Answer 3

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

Answer 4

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

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

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

Answer 5

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

wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText