How to add further text in an e-mail body after excel table is inserted (VBA)

77 Views Asked by At

I need to insert an excel table within an e-mail body. I have a code that inserts the table but I could not figure out yet how to add text after the table. Is there a way to somehow insert the table inside an e-mail body or to add text after it?

Here's my current code:

Sub RangeToOutlook_Single()

Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector
Dim wsSmy As Worksheet, wsCP As Worksheet
Dim LastRow As Integer, LastColumn As Integer
Dim StartCell As Range
Dim oWrdDoc As Word.Document
Dim oWrdRng As Word.Range
Dim ExcRng As Range

On Error Resume Next

Set oLookApp = GetObject(, "Outlook.Application")

    If Err.Number = 429 Then
        Err.Clear
        Set oLookApp = New Outlook.Application
    End If
    
Set oLookItm = oLookApp.CreateItem(olMailItem)

Set wsSmy = Workbooks("HRDA Audit_Master.xlsb").Sheets("SUMMARY")
Set wsCP = Workbooks("HRDA Audit_Master.xlsb").Sheets("Control Panel")
Set StartCell = wsSmy.Range("A1")
LastRow = wsSmy.Cells(wsSmy.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = wsSmy.Cells(StartCell.Row, wsSmy.Columns.Count).End(xlToLeft).Column
Set ExcRng = wsSmy.Range("A1:R" & LastRow)

With oLookItm
    .To = Range("S" & LastRow)
    .CC = ""
    .Subject = "HRDA Audit - " & wsCP.Range("B1")
    .Body = "Dear " & wsSmy.Range("T" & LastRow) & "," & vbLf & vbLf & _
    "Here is the first half of the text before the table."
    .Display
    
    Set oLookIns = .GetInspector
    Set oWrdDoc = oLookIns.WordEditor
    Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
        oWrdRng.Collapse Direction:=wdCollapseEnd

    ExcRng.Copy
    oWrdRng.Paste
End With
       
End Sub

If I add for example: .Body = .Body & "text" it will re-paste the whole thing but losing the table format. Can somebody help me amend the above code so I can have text surround the table? Thanks in advance.

1

There are 1 best solutions below

0
On

Try

    ExcRng.Copy
    oWrdDoc.Paragraphs.Add.Range.Paste
    
    With oWrdDoc.Paragraphs.Add.Range
        .Text = "Here is some text"
        .Font.Name = "Arial Unicode MS"
        .Font.Size = 24
        .Font.Bold = True
    End With