Outllok insert word as Message Body

[Billucky]

Hello there,

I have a code that sents an email to the reciepents I want, with the attachement i need

The problem is tha in the message of the mail I want after this:
[FONT=&quot]To: [/FONT]<o></o>Recipient1
[FONT=&quot]ATTN: [/FONT]<o></o>Attn
[FONT=&quot]Dear [/FONT]<o></o>Recipient2


to input a message from a specific word document

So we have:

With OutMail
.To = cell.Value
.Subject = Subj
.body = "To:" & " " & Recipient1 & " " & vbNewLine & vbNewLine _
& "ATTN:" & " " & Attn & vbNewLine & vbNewLine & _
"Dear" & " " & Recipient2 _
HERE THE TEXT FROM THE WORD DOCUMENT MUST BE ENTERED

Can anybody please provide some help?

 

[strive4peace]

use .htmlbody instead of .body if you want to embed html in the body

what is <o></o> for ?

I am really not clear on what you are after. Please post all the code -- and use CODE tags

BB Code List - MrExcel Message Board

 

[Billucky]

Thank you for your response.

Actually all the s <o></o> was a wrong paste
This is the code

Sub Send_Email_Current_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim filepath As String
Dim Subj As String
Dim EmailAddr As String
Dim Recipient1 As String
Dim Recipient2 As String
Dim Attn As String
Dim Msg As String
Dim HLink As String
Dim Message As String
Dim atatch As String
Dim bodymsg As String
 

   For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
     Set OutApp = CreateObject("Outlook.Application")
     OutApp.Session.Logon
     Set OutMail = OutApp.CreateItem(0)


  If cell.Value Like "*@*" Then
      'Get the data
      Subj = cell.Offset(0, 3).Value
      Recipient1 = cell.Offset(0, -1).Value
      Attn = cell.Offset(0, 1).Value
      Recipient2 = cell.Offset(0, 2).Value
      Message = cell.Offset(0, 4).Value
      EmailAddr = cell.Value
      atatch = cell.Offset(0, 5).Value
     
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = Subj

.Body = ?????

 .Attachments.Add atatch
 .Display
'.Send

So at the .Body = ????? part i need something that retrieves all the data from a specific document (doc or rtf or html) but it has to maintain the format (colors, underlined text, bold etc.)

 

[s.ridd]

This is tested with Office 2007. I've used Early Binding because it is much easier/quicker (so remember to set a reference to the Word and Outlook object models) however it could be adapted to use Late Binding (although if you do and you're testing it you may want to add a wdApp.Visible = True line incase there are any errors loading the word file)

Sub SendWordDoc()Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim outApp As Outlook.Application
Dim outMailItem As Outlook.MailItem
Dim strGreeting


    Set wdApp = New Word.Application
    Set wdDoc = wdApp.Documents.Open("C:\filetobesent.docx")
    
    strGreeting = "Dear Blah," & vbNewLine
    
    wdDoc.Characters(1).InsertBefore strGreeting
    
    Set outApp = New Outlook.Application
    Set outMailItem = wdDoc.MailEnvelope.Item
    
    With outMailItem
        .To = "joe@bloggs.com"
        .Subject = "word"
        .Send
    End With
    
    outApp.Quit
    wdDoc.Close wdDoNotSaveChanges
    wdApp.Quit
    
    Set outMailItem = Nothing
    Set outApp = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing


End Sub

Now you just need to wrap this inside your original code.

What is it doing? Well it is opening your specified word document and then inserting your greeting/salutation before the original content. It is then setting a mailitem to that word document and giving it a recipient, subject and attachment then sending. I'd suggest testing this with the .To as your email address. Note - it will ignore any header/footers you have. If you want them (not sure why?) then you'd need to fetch those separately.

Hope this helps and let me know if you have any problems.

Simon

 

[Billucky]

Dear Simon ,

Thank you very much for your help.

I have tried your code by itself and implementing to my code as well.
The same error keeps coming up

Run-Time error '-2147467259 (80004005)
Method 'MailEnvelope' of Object'_Document' Failed.

Can you understand what is the problem? (i also have Office 2007)

 

[s.ridd]

Unfortunately I can't recreate the error. I know that Outlook needs to be your default mail program but beyond that I don't really know. I knocked this code up quite quickly yesterday so it could be improved, I've added in a few of those improvements quickly. The other option would be to add an introduction to the mailenvelope with a line like

wdDoc.MailEnvelope.Introduction = strGreeting

and then remove all other references. However this might not suit your needs and I also don't know how it would stop the problem.

Also I googled the error (as I haven't come across it before) there doesn't seem to be much information but there is a suggestion of saving the email before sending. So I've included that option (you'll probably need to change the loop calculation which deletes out your strGreeting from the beginning).

Sub SendWordDoc()Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim outApp As Outlook.Application
Dim outMailItem As Outlook.MailItem
Dim strGreeting As String
Dim i As Integer
Dim bWdOpen As Boolean
Dim bOutOpen As Boolean


On Error Resume Next
    Set wdApp = New Word.Application
On Error GoTo 0


    If Not wdApp Is Nothing Then
        bWdOpen = True
    Else
        bWdOpen = False
        Set wdApp = New Word.Application
    End If
    
    Set wdDoc = wdApp.Documents.Open("C:\filetobesent.docx")
    
    strGreeting = "Dear Blah," & vbNewLine
    
    wdDoc.Characters(1).InsertBefore strGreeting
    wdDoc.Save


On Error Resume Next
    Set outApp = New Outlook.Application
On Error GoTo 0


    If Not outApp Is Nothing Then
        bOutOpen = True
    Else
        bOutOpen = False
        Set outApp = New Word.Application
    End If
    
    Set outMailItem = wdDoc.MailEnvelope.Item
    
    With outMailItem
        .To = "joe@bloggs.com"
        .Subject = "word"
        .Send
    End With
    
    For i = 1 To Len(strGreeting) - 2
        wdDoc.Characters(1).Delete
    Next i
    
    If bOutOpen = False Then outApp.Quit
    wdDoc.Close wdSaveChanges
    If bWdOpen = False Then wdApp.Quit
    
    Set outMailItem = Nothing
    Set outApp = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing


End Sub

Try this code and make sure Outlook 2007 is your default mail program and if it still isn't working let me know and I'll have a rethink.

Simon

 

[Billucky]

Dear Simon,

Thanks again for your help.

Although I have tried everything I the above mentioned code, the same error seems to appear.
Outlook is my default mail program (in fact the only one), maybe it has to do with the fact that although I have Offiice 2007, Outlook is 2003. I will try it again this weekend, where I will have access to another pc.

I have tried to make something else:

[/COLOR]
 Dim OL As Object
 Dim W As Object
 Dim MsgTxt As String, SendFile As String
 Dim ToRangeCounter As Variant
 
  


 SendFile = Application.GetOpenFilename(Title:="Select MS Word " & "file to mail, then click 'Open'", buttontext:="Send", _
     MultiSelect:=False)




 Set W = GetObject(SendFile)
 
 
 MsgTxt = W.Range(Start:=W.Paragraphs(1).Range.Start, _
 End:=W.Paragraphs(W.Paragraphs.Count).Range.End)




 Set W = Nothing

  On Error Resume Next
             With OutMail
            .To = cell.Value
            .Subject = Subj
            .Body = MsgTxt
[COLOR=#574123][code][/COLOR]

It works and i get the data from the word document, but my main problem remains.....
I keep loosing the format of the text in the word document. Maybe you have some idea of what needs to be changed in order for the data to maintain their format?

Again thanks for all your help

 

[s.ridd]

Ah, there is the source of your problem. MailEnvelope requires that Outlook is either the same version as Word or later. So if you are using Outlook 2003 and Word 2007 then it won't work.

I'm not sure I can think of any other way of maintaining the formatting but I will put my thinking cap on and let you know either way.


Simon

P.S. I say "any other way" - you could always email the word document as an attachment?

 

[Billucky]

Thanks again.

I will try it to another pc with word and oultook to be 2007. I will post back my results, even if it takes some time to do so.

P.S. Yes, i know. But actually I want the mail to have an attachement as well!!

Billucky

 

[s.ridd]

OK, after a little playing I wondered whether I could just simply copy and paste the information. I have tested tables, fonts and hyperlinks and the formatting appears to be retained. Let me know if this works for you. I had to display the windows for the paste to work but I guess that it isn't the end of the world if it flashes up for a split second. Funny how the simple answer can evade you.

Let me know how you get on

Sub SendWordDoc()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim outApp As Outlook.Application
Dim outMailItem As Outlook.MailItem
Dim outInsp As Outlook.Inspector
Dim strGreeting As String
Dim bWdOpen As Boolean
Dim bOutOpen As Boolean

On Error Resume Next
    Set wdApp = Word.Application
On Error GoTo 0

    If Not wdApp Is Nothing Then
        bWdOpen = True
    Else
        bWdOpen = False
        Set wdApp = New Word.Application
    End If
    
    wdApp.Visible = True
    
    Set wdDoc = wdApp.Documents.Open("C:\filetobesent.docx")
    
    strGreeting = "Dear Blah," & vbNewLine
    
    wdDoc.Characters(1).InsertBefore strGreeting

On Error Resume Next
    Set outApp = Outlook.Application
On Error GoTo 0

    If Not outApp Is Nothing Then
        bOutOpen = True
    Else
        bOutOpen = False
        Set outApp = New Outlook.Application
    End If
    
    Set outMailItem = outApp.CreateItem(olMailItem)
    Set outInsp = outMailItem.GetInspector
    
    outInsp.Display
    wdDoc.Content.Copy
    outInsp.WordEditor.Content.Paste
    
    With outMailItem
        .To = "joe@bloggs.com"
        .Subject = "word"
        .Send
    End With

    If bOutOpen = False Then outApp.Quit
    wdDoc.Close wdDoNotSaveChanges
    If bWdOpen = False Then wdApp.Quit
    
    Set outInsp = Nothing
    Set outMailItem = Nothing
    Set outApp = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing

End Sub

Simon