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

 

[beczer]

Run-time error '-2147352565 (8002000b)

Nothing more

 

[beczer]

Any idea ?

 

[Worf]

This version attempts to find out what is going wrong:

' 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, insp As Inspector
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
    Set insp = .GetInspector
    If Not insp.IsWordMail Or insp.EditorType <> olEditorWord Then
        MsgBox "This code will not work for you", vbCritical
        Exit Sub
    End If
    .To = rngTo
    .Subject = rngSubject
    Set editor = insp.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