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