Exporting rich text to outlook and keep formatting - vba

Question

I have a button in Access that opens Outlook, creating an appointment.
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:
<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)
It seems many people have solution for Excel, but I am struggling to get them to work in 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

To pass RTF formatted string to outlook email body is simple as following
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.

Answer 2

You can use a little extra overhead to create a message with the formatted HTMLBody content, then copy the content to an Appointment item.
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.
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.

Answer 3

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

Answer 4

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 I cant 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

Answer 5

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