Export Word Table into Outlook Email Body

[Loss1003]

How can I edit the following code, in-which copies a table to clipboard, and then the coiped table iinserted into an outlook email body.

Private Sub CommandButton4_Click()
With ActiveDocument
    .Tables(1).Range.Copy
    .Range(1, 1).Select
ActiveDocument.Tables(1).Cell(2, 1).Select
  
  
End With
End Sub

Currently using word 2010 and outlook professional plus 2010

[gmayor]

The following should do that. You can replace the subject, the texts and the recipient as required:

Private Sub CommandButton4_Click()
Dim olApp As Object
Dim oMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object

    On Error Resume Next
    If ActiveDocument.Tables.Count > 0 Then
        ActiveDocument.Tables(1).Range.Copy
        Set olApp = GetObject(, "Outlook.Application")
        If Err <> 0 Then
            Set olApp = CreateObject("Outlook.Application")
        End If
        'On Error GoTo lbl_Exit
        Set oMail = olApp.CreateItem(0)
        With oMail
            .to = "someone@somewhere.com"
            .Subject = "Message Subject"
            .BodyFormat = 2
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range(0, 0)
            .Display        'This line is required.
            oRng.Text = "This is the text before the table." & vbCr & vbCr
            oRng.Collapse 0
            oRng.Paste
            oRng.Collapse 0
            oRng.Text = vbCr & "This is the text after the table, before the signature."
            '.Send  'Restore this line to send the message
        End With
    Else
        MsgBox "No table!"
    End If
    ActiveDocument.Tables(1).Cell(2, 1).Select
lbl_Exit:
    Set olApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[Loss1003]

Great works perfectly.

How can i copy cell (2 and 4) from row (2) and insert into the .subject line. I tried tinkering around with the following and few other variations but it only picks up the first or last cell only and not both.

.Subject = ActiveDocument.Tables(1).Cell(2, 2).Range & .Subject = ActiveDocument.Tables(1).Cell(2, 4).Range

[gmayor]

Presumably these cells are in the table being copied? That being the case add a couple of declarations at the top

Dim oCell As Range
Dim strSubject As String

Modify the code as follows

If ActiveDocument.Tables.Count > 0 Then
        Set oCell = ActiveDocument.Tables(1).Cell(2, 2).Range
        oCell.End = oCell.End - 1 'remove the cell end character
        strSubject = oCell.Text
        Set oCell = ActiveDocument.Tables(1).Cell(2, 4).Range
        oCell.End = oCell.End - 1'remove the cell end character
        'Add the cell text to the subject string
        strSubject = strSubject & Chr(32) & oCell.Text

and insert the subject string into the message

.Subject = strSubject

[naeemakhtar]

Please advise if the code can be revised to remove the border that is displayed around the table in the body of the email.

[gmayor]

Add another value to the Dim statements

Dim oBorder As Object

Then add the following where shown

oRng.Text = vbCr & "This is the text after the table, before the signature."
'.Send 'Restore this line to send the message
With wdDoc.Tables(1)
For Each oBorder In .Borders
oBorder.LineStyle = 0
Next oBorder
End With
End With

[microware197]

I have this code working and can change ActiveDocument.Tables(1).Range.Copy with any number in the ( ) to select that table from the document to send in the email. I would like a drop down to open when the macro is run to allow selection of which table to be copied. This could simply be by number or a nickname (preferred), then that number would populate ActiveDocument.Tables(x).Range.Copy and copy the correct table into the email body. TIA.

[gmayor]

This is an old thread and it would have been advisable to start a new one, however. If you want to select from a list of tables, then bookmark the tables with suitable names.

Create a simple userform with a combo box and a command button - https://www.gmayor.com/Userform.htm

The code for the userform is

Option Explicit

Private Sub CommandButton1_Click()
    Hide
End Sub

Then use the following code to call the userform and create the message. Note especially the comment at the top of the code as it won't work otherwise.

Note the userform uses the default names here for the form and its controls. If you need to change them, you will have to change them in the code also.

Option Explicit

Private Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 20 Dec 2019
'This macro requires the code from the following link to open Outlook correctly
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm


Dim olApp As Object
Dim oMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim oFrm As UserForm1
Dim lngTable As Long
Dim oBM As Bookmark


    On Error Resume Next
    If ActiveDocument.Tables.Count > 0 Then


        Set oFrm = New UserForm1
        With oFrm
            .ComboBox1.AddItem "[Select Table]"
            For Each oBM In ActiveDocument.Bookmarks
                If oBM.Range.Tables.Count > 0 Then
                    .ComboBox1.AddItem oBM.Name
                End If
            Next oBM
            .ComboBox1.ListIndex = 0
            .Show
            If .ComboBox1.ListIndex < 1 Then
                MsgBox "No table selected"
                GoTo lbl_Exit
            End If
            lngTable = .ComboBox1.ListIndex
        End With
        Unload oFrm


        ActiveDocument.Tables(lngTable).Range.Copy
        Set olApp = OutlookApp()
        On Error GoTo 0
        Set oMail = olApp.CreateItem(0)
        With oMail
            .to = "someone@somewhere.com"
            .Subject = "Message Subject"
            .BodyFormat = 2
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range(0, 0)
            .Display        'This line is required.
            oRng.Text = "This is the text before the table." & vbCr & vbCr
            oRng.Collapse 0
            oRng.Paste
            oRng.Collapse 0
            oRng.Text = vbCr & "This is the text after the table, before the signature."
        End With
        '.Send  'Restore this line to send the message
    Else
        MsgBox "No table!"
    End If
lbl_Exit:
    Set olApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Set oFrm = Nothing
    Exit Sub
End Sub

[CHARHOLD]

Hi gmayor

I just stumbled upon this thread and the original code is almost exactly what I am looking for in one of my projects and I was wondering if you could possibly help please.

I was trying to update the code to send multiple tables, for example in my code I would like to take tables 1 , 2, 8 & 9 and drop into the body of the email, but every time I tried kept getting errors .

Also is it possible to add a line of code to attach the active document to the email and name the subject of the email the active name?

If you could advice that would be amazing as I'm quite the macro novice.

[gmayor]

Maybe something like

Option Explicit

Private Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 29 Nov 2022
'This macro requires the code from the following link to open Outlook correctly
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm


Dim olApp As Object
Dim oMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oDoc As Document
Dim oRng As Object
Dim lngTable As Long
Dim oBM As Bookmark


    On Error Resume Next
    If ActiveDocument.Tables.Count > 4 Then
        Set oDoc = ActiveDocument
        oDoc.Save
        Set olApp = OutlookApp()
        On Error GoTo 0
        Set oMail = olApp.CreateItem(0)
        With oMail
            .to = "someone@somewhere.com"
            .Subject = oDoc.Name
            .BodyFormat = 2
            .Attachments.Add oDoc.FullName
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range(0, 0)
            .Display        'This line is required.
            oRng.Text = "This is the text before the tables." & vbCr & vbCr
            oRng.Collapse 0
            For lngTable = 1 To 9
                If lngTable = 1 Then
                    oDoc.Tables(lngTable).Range.Copy
                    oRng.Paste
                    oRng.Collapse 0
                    oRng.Text = "Table " & lngTable & vbCr
                    oRng.Collapse 0
                End If
                If lngTable = 2 Then
                    oDoc.Tables(lngTable).Range.Copy
                    oRng.Paste
                    oRng.Collapse 0
                    oRng.Text = "Table " & lngTable & vbCr
                    oRng.Collapse 0
                End If
                If lngTable = 8 Then
                    oDoc.Tables(lngTable).Range.Copy
                    oRng.Paste
                    oRng.Collapse 0
                    oRng.Text = "Table " & lngTable & vbCr
                    oRng.Collapse 0
                End If
                If lngTable = 9 Then
                    oDoc.Tables(lngTable).Range.Copy
                    oRng.Paste
                    oRng.Collapse 0
                    oRng.Text = "Table " & lngTable & vbCr
                    oRng.Collapse 0
                End If
            Next lngTable
            oRng.Text = vbCr & "This is the text after the tables, before the signature."
        End With
        '.Send  'Restore this line to send the message
    Else
        MsgBox "No tables!"
    End If
lbl_Exit:
    Set olApp = Nothing
    Set oDoc = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub