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




Reply With Quote