将富文本导出到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？（也许使用剪贴板）

似乎很多人都解决了Excel中，但我努力让他们在获得工作：

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

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

Answer 1

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

我在我的家用机器上工作，但不在客户机上工作。所以我不能使用它，但如果你能改善它，让我知道。

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 2

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

Answer 3

您可以使用一些额外开销创建具有格式化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 

此代码测试，在访问2013年

Answer 4

正如在前面的回答，这条线是关键，它复制文本，超链接，图片等，而无需修改剪贴板中的内容：

wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText 

Answer 5

要通过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(strBody, vbFromUnicode) 'Convert RTF string to byte array 
    End With 
    Set myOlApp = Nothing 
    Set myOlItem = Nothing 
End Function 

秘密不使用“.RTFBody”只是“体”和传递给它的字节数组如在上面的代码。我花了一段时间才弄明白。 感谢Microsoft，我们总是会找出一些想法。