Copy multiple tables into email body

[martin0852]

Hi All,

I am working on a word document which contains 13 separate unique tables.

I am having an issue whereby I need to create two emails, one which has all the tables included and another which only tables 2,6 and 9-13 included but am unable to copy and paste in this order.

The first part is easily accomplished thanks to the following code I have been using from an online source (possibly here as I have it so long I can no longer recall):


Sub Email_Click()

ActiveDocument.Save


Dim oAp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim oInsp As Outlook.Inspector
Dim wdEditor
Dim multiRange As Range
Dim strBody As String

'~~> Get/Create an instance of Outlook
Set oAp = GetObject(, "Outlook.Application")


'~~> Create new item
Set oItem = oAp.CreateItem(olMailItem)


'~~> Copy all tables
Set multiRange = ActiveDocument.Range(Start:=ActiveDocument.Tables(1).Range.Start, End:=ActiveDocument.Tables(13).Range.End)
multiRange.Copy

Set oInsp = oItem.GetInspector
Set wdEditor = oInsp.WordEditor

'~~> Display the message
oItem.Display
With oItem
.To = ""
.CC = ""
.BCC = ""
.Subject = "subject"
.HTMLBody = rng


End With

'~~> Paste the table in the email body
wdEditor.Characters(1).PasteAndFormat (wdFormatOriginalFormatting)

'~~> Flushing the Toilet

Set oItem = Nothing
Set oAp = Nothing
Set oInsp = Nothing
Set wdEditor = Nothing

End Sub


Now I have tried to loop through the code above in a basic way by going back over the copy-paste routine but the newest copied table gets nested within the top left-most cell of the last table copied into the email body so this doesn't work. Possibly I am missing something with the "flushing the toilet" part?

So my questions to ye experts are as follows:

Is there a way to copy multiple tables that are not in a nice order, so for example tables 2, 4 and 9 through 13 and paste into email body as per above code?

or failing that is there a way to loop through the copy-paste routine so that each new copied table has a space between it and the last table?

Thanks in advance for the help

[gmayor]

How about


Option Explicit
Sub Email_Click()

Dim oAp As Object
Dim oItem As Object
Dim oInsp As Object
Dim wdEditor As Object
Dim oRng As Range
Dim oTable As Range
Dim i As Long

'~~> Get/Create an instance of Outlook
On Error Resume Next
Set oAp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oAp = CreateObject("Outlook.Application")
End If
On Error GoTo 0

'ActiveDocument.Save
'~~> Create new item
Set oItem = oAp.CreateItem(0)

Set oInsp = oItem.GetInspector
Set wdEditor = oInsp.WordEditor

'~~> Display the message
oItem.Display
With oItem
.to = ""
.CC = ""
.BCC = ""
.Subject = "subject"
.BodyFormat = 2 'HTML
End With

'~~> Paste the tables in the email body
For i = 1 To ActiveDocument.Tables.Count
Select Case i
Case 2, 6, 9, 10, 11, 12, 13
Set oTable = ActiveDocument.Tables(i).Range
oTable.End = oTable.End + 1
oTable.Copy
Set oRng = wdEditor.Range
oRng.Collapse wdCollapseStart
If wdEditor.Tables.Count > 0 Then
oRng.End = wdEditor.Tables(wdEditor.Tables.Count).Range.End + 1
oRng.Collapse wdCollapseEnd
End If
oRng.Paste
Case Else
End Select
Next i
'~~> Flushing the Toilet

Set oItem = Nothing
Set oAp = Nothing
Set oInsp = Nothing
Set wdEditor = Nothing

End Sub

[martin0852]

How about


Option Explicit
Sub Email_Click()

Dim oAp As Object
Dim oItem As Object
Dim oInsp As Object
Dim wdEditor As Object
Dim oRng As Range
Dim oTable As Range
Dim i As Long

'~~> Get/Create an instance of Outlook
On Error Resume Next
Set oAp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oAp = CreateObject("Outlook.Application")
End If
On Error GoTo 0

'ActiveDocument.Save
'~~> Create new item
Set oItem = oAp.CreateItem(0)

Set oInsp = oItem.GetInspector
Set wdEditor = oInsp.WordEditor

'~~> Display the message
oItem.Display
With oItem
.to = ""
.CC = ""
.BCC = ""
.Subject = "subject"
.BodyFormat = 2 'HTML
End With

'~~> Paste the tables in the email body
For i = 1 To ActiveDocument.Tables.Count
Select Case i
Case 2, 6, 9, 10, 11, 12, 13
Set oTable = ActiveDocument.Tables(i).Range
oTable.End = oTable.End + 1
oTable.Copy
Set oRng = wdEditor.Range
oRng.Collapse wdCollapseStart
If wdEditor.Tables.Count > 0 Then
oRng.End = wdEditor.Tables(wdEditor.Tables.Count).Range.End + 1
oRng.Collapse wdCollapseEnd
End If
oRng.Paste
Case Else
End Select
Next i
'~~> Flushing the Toilet

Set oItem = Nothing
Set oAp = Nothing
Set oInsp = Nothing
Set wdEditor = Nothing

End Sub


Brilliant!

Works perfectly up to table 10, seems to stop pasting at this point for some reason???

Any ideas why?
It does appear to be doing something though...hmm

As a workaround I just combined all 9-13 into 1 table..no biggie but if you have an idea why table 9 is the last one to be inserted I would be interested in knowing!

Thanks a million for the solution by the way! Brilliant stuff!

[gmayor]

I can't think of any good reason why it should stop pasting. It pastes all the required tables here.

I take it that you didn't manage to lose the last part of
Case 2, 6, 9, 10, 11, 12, 13

[martin0852]

I can't think of any good reason why it should stop pasting. It pastes all the required tables here.

I take it that you didn't manage to lose the last part of
Case 2, 6, 9, 10, 11, 12, 13

No definitely still there...hmm..

Anyway I think it's not an issue with the code maybe my implementation as the rest works fine!

Thanks a million..i guess this is solved