Word -> Outlook Email Body

[beczer]

Hi everyone

I'm new here and VBA beginner but I need to create something what is too advanced for me at this moment. So I hope you can help me.

So what I need:

I want to create a Macro which Export Part of Word Content (Text and Tables) into Outlook Email body. So I think that I have to use Bookmarks in Word as a reference and probably generate HTML tables.

Every hint, advise will be valuable for me.

Thank you in advance !

Tom

 

[Worf]

This example copies all tables in the document to the email body:

' Word macro
Sub Tables_to_Outlook()
Dim oAp As Object, oItem As Object, oInsp As Object, wded As Object
Dim rng As Range, oTable As Range, i&
On Error Resume Next
Set oAp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set oAp = CreateObject("Outlook.Application")
On Error GoTo 0
Set oItem = oAp.CreateItem(0)
Set oInsp = oItem.GetInspector
Set wded = oInsp.WordEditor
oItem.Display
With oItem
    .To = "crosbyd@cbs.com"
    .CC = "hamilton.l.c@mercedes.de"
    .BCC = "sharapovam@wada.org"
    .Subject = "subject"
    .BodyFormat = 2                                  'HTML
End With
For i = 1 To ActiveDocument.Tables.Count
    Set oTable = ActiveDocument.Tables(i).Range
    oTable.End = oTable.End + 1
    oTable.Copy
    Set rng = wded.Range
    rng.Collapse wdCollapseStart
    If wded.Tables.Count > 0 Then
        rng.End = wded.Tables(wded.Tables.Count).Range.End + 1
        rng.Collapse wdCollapseEnd
    End If
    rng.Paste
Next
Set oItem = Nothing: Set oAp = Nothing
Set oInsp = Nothing: Set wded = Nothing
End Sub

 

[beczer]

Many thanks Worf

I modified above VBA codes and prepared mix of all above which fits to my need, but it doesn't work and I would like to ask you to take a look and help me to do it well.

' Word macro
Sub emailFromDoc()
Dim olook As Object, editor As Object, oMail As MailItem, bmk As Bookmark
Set bmk = ActiveDocument.Bookmarks("bm2")
bmk.Range.Copy
Set olook = CreateObject("Outlook.Application")
Set oMail = olook.CreateItem(olMailItem)
With oMail
.Display
.BodyFormat = olFormatRichText
.Subject = t.Cell(A1).Range.Text ' from cell
.To = t.Cell(A2).Range.Text
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Save
.Attachments.Add => it should attached pdf from Active Doc.Word or Active PDF or from link in Cell A1.
.Save
' .Send
End With
End Sub

Thanks

 

[Worf]

Is this what you want?

' Word module
Sub emailFromDoc()
Dim olook As Object, editor As Object, oMail As MailItem, _
bmk As Bookmark, xl As Object, wb As Workbook
Set bmk = ActiveDocument.Bookmarks("bm2")
bmk.Range.Copy
Set olook = CreateObject("Outlook.Application")
Set xl = CreateObject("Excel.Application")
xl.Visible = 1
Set wb = xl.Workbooks.Open("d:\pub\solver.xlsm")                ' your path here
Set oMail = olook.CreateItem(olMailItem)
ActiveDocument.SaveAs2 "d:\pub\doccopy.pdf", wdFormatPDF        ' create PDF
With oMail
    .Display
    .BodyFormat = olFormatRichText
    .Subject = wb.sheets("sheet1").[b2]                         ' from Excel
    .To = wb.sheets("sheet1").[d2]
    Set editor = .GetInspector.WordEditor
    editor.Content.Paste
    .Save
    .Attachments.Add "d:\pub\doccopy.pdf", olByValue, 1
    .Save
    ' .Send
End With
Set editor = Nothing:        Set oMail = Nothing
Set wb = Nothing:            Set xl = Nothing
Set olook = Nothing:         Set bmk = Nothing
End Sub

 

[beczer]

Thanks Worf for your another quick reply. Below this is what I really need. I have to do only one change.

Sub CreateMail()

Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim rng2 As Range
Dim ws As Worksheet




Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)


Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1")


With ws
    Set rngTo = .Range("B1")
    Set rngSubject = .Range("B2")
    Set rngBody = .Range("B3")
    Set rngAttach = ws.Range(ws.[b4], ws.Cells(Rows.Count, "B").End(xlUp))
End With


With objMail
    .To = rngTo.Value
    .Subject = rngSubject.Value
    .body = rngBody.Value
    For Each rng1 In rngAttach.Cells
        If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value
    Next


    .display 


End With


Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing


End Sub

This is what I really need but I don't know how to modify

Set rngBody = .Range("B3")

into Active Word Doc. Bookmark Body

Set rngBody = ActiveDocument.Bookmarks("bm2")

Thanks

Tom

 

[beczer]

Nobody know how to modify it ?

 

[Worf]

Maybe I know:

' Excel module
Sub CreateMail()
Dim objOutlook As Object, objMail As Object, rngTo As Range, rngSubject As Range, wd, editor, _
rngAttach As Range, ws As Worksheet, rng1, wdoc, bmk
Set wd = CreateObject("Word.Application")
wd.Visible = 1
Set wdoc = wd.Documents.Open("d:\pub\model3.docx")                  ' your path here
Set bmk = wdoc.Bookmarks("bm2")
bmk.Range.Copy
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set ws = Worksheets("Sheet1")
With ws
    Set rngTo = .Range("B1")
    Set rngSubject = .Range("B2")
    Set rngAttach = .Range(.[b4], .Cells(Rows.Count, "B").End(xlUp))
End With
With objMail
    .To = rngTo.Value
    .Subject = rngSubject
    Set editor = .GetInspector.WordEditor
    editor.Content.Paste                                            ' from bookmark
    For Each rng1 In rngAttach.Cells
        If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value
    Next
    .Display
End With
wdoc.Close
Set objOutlook = Nothing:   Set objMail = Nothing
Set rngTo = Nothing:        Set rngSubject = Nothing
Set rngAttach = Nothing
End Sub

 

[beczer]

Hi Worf

As always I can rely on you. Many thanks!!!

Two things

1. Above code unfortunatelly doesn't work well - Run-time error '-2147352565 (8002000b)

2. I would be so grateful if you could help me to (based on above code) take mail body not from link to the file but from active Word Document

Thanks

 

[Worf]

• What code line throws the error? What is the message? Please test the new version below.
• Note that it is an Excel macro.

' Excel module
Sub CreateMail()
Dim objOutlook As Object, objMail As Object, rngTo As Range, rngSubject As Range, wdapp, editor, _
rngAttach As Range, ws As Worksheet, rng1, wdoc, bmk
On Error Resume Next
Set wdapp = GetObject(, "Word.Application")                         ' Word already open
On Error GoTo 0
If wdapp Is Nothing Then
    MsgBox "No instances of Word found"
    Exit Sub
End If
wdapp.Visible = 1
Set wdoc = wdapp.ActiveDocument                                     ' desired Word document
Set bmk = wdoc.Bookmarks("bm2")
bmk.Range.Copy
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set ws = Worksheets("Sheet1")
With ws
    Set rngTo = .[B1]
    Set rngSubject = .[B2]
    Set rngAttach = .Range(.[b4], .Cells(Rows.Count, "B").End(xlUp))
End With
With objMail
    .To = rngTo
    .Subject = rngSubject
    Set editor = .GetInspector.WordEditor
    editor.Content.Paste                                            ' from bookmark
    For Each rng1 In rngAttach.Cells
        If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value
    Next
    .Display
End With
'wdoc.Close
Set objOutlook = Nothing:   Set objMail = Nothing
Set rngTo = Nothing:        Set rngSubject = Nothing
Set rngAttach = Nothing
End Sub

 

[beczer]

Hey Worf

Thanks. Above error (still exist) underlines Set ws = Worksheets("Sheet1")

Update: I change sheet name and it works fine but then there is an error with

Set editor = .GetInspector.WordEditor (underline)

 

[Worf]

What is the error number and message when it stops at the editor line?