Outlook and Word using Access

[Ablima]

Programming in Access. Access version: 2007


I am trying to send emails using a text that I have in Word file.
This text is in rtf format and contains tables.
I'm using Outlook to send emails. Outlook version: 2007.
When I copy the text in the body of the email I had obtained in the word file there is a loss in the formatting, that is, the tables disappear, recording only the contents of the tables.
In the example below I only send one email, but the idea is to do it on a large scale.
Does anyone know where the problem is?




Program Code
=========


Option Compare Database
Option Explicit


Sub teste()


Dim DirExecucao As String


DirExecucao = "D:\A Particular"


Dim MyOutlook As Outlook.Application
Set MyOutlook = New Outlook.Application


Dim Mensagem As Object


Dim WordPlan As Object
Set WordPlan = CreateObject("Word.application")
WordPlan.Application.Visible = True
WordPlan.ChangeFileOpenDirectory DirExecucao
WordPlan.Documents.Open FileName:="saida.rtf", ReadOnly:=False


WordPlan.Selection.WholeStory
WordPlan.Selection.Copy


Set Mensagem = MyOutlook.CreateItem(0)

Mensagem.To = TabEmail(ordem(i))
Mensagem.Subject = "Informações sobre convênios"
Mensagem.BodyFormat = 3

Dim MyData As DataObject
Set MyData = New DataObject
MyData.GetFromClipboard

On Error Resume Next

Mensagem.Body = MyData.GetText(1)
'Mensagem.Body = MyData.GetText(2) ' I think it should be this to read in RTF format, but it did not work

Mensagem.Display
Mensagem.Send


WordPlan.ActiveDocument.Close
WordPlan.Quit
Set WordPlan = Nothing


GoTo fim


Trata_erro:


MsgBox ("deu erro")
If Err.Number = 53 Then
MsgBox "Mensagem de erro 1"
ElseIf Err.Number = 58 Then
MsgBox "Mensagem de erro 2"
Else
MsgBox "Mensagem de erro 3"
End If


fim:

End Sub

[June7]

See if this helps https://stackoverflow.com/questions/...eep-formatting

[ranman256]

Why do you need access if all the data is in Word?
Code it via word.

[Ablima]

Thanks for help but it also does not work

[Ablima]

I saw it on Microsoft's website, when asking for GetFormat:
"The DataObject currently supports only text formats."


This kills my possibilities of solving the problem along this path

[June7]

This was a challenge but finally got something working. Adapted from https://stackoverflow.com/questions/...ent-email-body.

Sub RTFemail()
    Dim doc As Object, sel As Object
    Dim oWord As Object, oDoc As Object, wRng As Object

    '~~> Establish a Word application object
    On Error Resume Next
    Set oWord = GetObject(, "Word.Application")
    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oWord = CreateObject("Word.Application")
    End If
    Err.Clear
    On Error GoTo 0
    '~~> Open the RTF file
    Set oDoc = oWord.Documents.Open(FileName:="C:\Test.rtf", ConfirmConversions:=False, _
        ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=0, XMLTransform:="", _
        Encoding:=1200)
    '~~> Get the complete text and copy it
    Set wRng = oDoc.Range
    wRng.Copy
    '~~> Close word Doc
    oDoc.Close

    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)
    With MailOutLook
        .To = "email address"
        .BodyFormat = olFormatRichText
        .Display
    End With

    '~~> Paste it in active email
    Set doc = appOutLook.ActiveInspector.WordEditor
    Set sel = doc.Application.Selection
    sel.Paste

    '~~> Clean up
    Set wRng = Nothing: Set oDoc = Nothing: Set oWord = Nothing
End Sub

[Ablima]

Thank so much June7.
I'll be try this code.
Otherwise, I solved the problem, but with a different structure, using Sendkeys.

My new code:

......
WordPlan.Selection.WholeStory
WordPlan.Selection.Copy
Set MinMensagem = MyOutlook.CreateItem(0)
MinMensagem.Display
MinMensagem.To = "aaaa@.gmail.com"
MinMensagem.Subject = "News from Brazil"
MinMensagem.Subject = "ISC"
AppActivate ("ISC")
SendKeys "{TAB}", True
SendKeys "{TAB}", True
SendKeys "{TAB}", True
SendKeys "^v", True
.......