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

问题是我想将Rich文本插入Body中，但它没有正确格式化，因为它显示所有HTML标记，例如：

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

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

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

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

秘诀不是使用＆＃34; .RTFBody＆＃34;但只是＆＃34; .Body＆＃34;并传递给它的字节数组，如上面的代码所示。我花了一段时间来搞清楚。感谢微软，我们总能找到解决办法。

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

我想出了一个解决方案。我刚刚复制并粘贴了整个sub，但答案就在那里我保证。我也强调了重点。

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

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

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

5 个答案: