將富文本導出到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，我們總是會找出一些想法。