VBA Outlook 邮件正文不显示（可能是由于表格通过 vba excel 粘贴到邮件正文中）

Question

I'm currently working on a vba excel macro that filters particular rows (based on values in one column), then copies particular columns from the filtered rows & paste them as a table into the outlook email body. I'd like the table to be pasted after the text in the email body. However, it seems that the table is the only thing that is in the mail body & I can't put the text before the table.

Would much appreciate your advice on how to display the text in the email body before the pasted table. My current: "OutMail.Body = "The body text I want to put before the table" does not work.

Code:

Option Explicit

Public ws As Workbook
Public ol As ListObject
Public olRng As Range

Sub copyTavletoEmail()
   Dim olCol AS Integer
   Dim datCol As Integer
   
   Application.ScreenUpdating = False
   
   Set ws = Sheets("Test1")
   Set ol = ws.ListObjects("tbClient")
   'remove table filters
   If ol.AutoFilter.FilterMode Then ol.AutoFilter.ShowAllData

   'clear table filters
   If ol.AutoFilter.FilterMode Then ol.AutoFilter.ShowAllData

   'get Valid column
    ol.Col = ol.ListColumns("Valid").Index

   'filter table
   ol.Range.AutoFilter field:=olCol, Criterial:="<0", Opertator:xlOr
dasds
   'remove table filter buttons
   ol.ShowAutoFilterDropDown = False
 
   'select table to copy

   'create mail
   Call CreateMail
 
   'clear table filters
   If ol.AutoFilter.FilterMode Then ol.AutoFilter.ShowAllData
 
   Application.ScreenUpdating = True
End Sub

Sub CreateMail()

Dim OutApp As Object
Dim OutMail As Object
Dim OutInsp As Object
Dim mailBcc As String, mailCC As String

Dim olCol As Integer
Dim rCell As Range
Dim addRng As Range

On Error GoTo errHandler

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'display mail
OutMail.display

'Subject & Body
OutMail.Subject = "Generic Subject"
OutMail.Body = "The body text I want to put before the table"
'Range of mail adresses
olCol = ol.ListColumns("Requestor email".Index
Set addRng = ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible)

'get the mail addresses
For Each rCell In addRng
   With OutMail
      mailBCC = mailBCC & rCell.Value & ";"
      mailCC = mailCC & rCell.Offset(0, 1).Value & ";"
   End With
Next rCell

OutMail.Bcc = mailBCC
OutMail.cc = mailCC

'Declare Word Variables
Dim oWrdDoc As Word.Document
Dim oWdEditor As Word.Editors
'Get the Active Inspector
Set OutInsp = OutMail.GetInspector

'Get the document within the inspector
Set oWrdDoc = OutInsp.WordEditor

'Email body
oWrdDoc.Range.InsertBefore strGreeting

'Hide unnecessarry columns

Range("B:H").EntireColumn.Hidden = True
Range("M:T").EntireColumn.Hidden = True

'copy table to paste in mail
olRng.Copy

'Define the range
Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content

'Paste the table
oWrdRng.Paste

'Unhide the hidden columns

Range("B:H").EntireColumn.Hidden = False
Range("M:T").EntireColumn.Hidden = False

exitRoutine:
'clear
Set OutMail = Nothing
Set OutApp = Nothing
Set ws = Nothing

Exit Sub

errHandler:
'Open immediate window to see the error
Debug.Print Err.Number, Err.Description

Resume exitRoutine

End Sub

Answer 1

Add a paragraph to the word document.

update - filter table, add signature to the end.

update2 = show only columns BJL

Option Explicit

Public ws As Worksheet
Public ol As ListObject
Public olRng As Range

Sub CopyTableToEmail()

   Dim olCol As Integer, datCol As Integer
  
   Set ws = Sheets("Test1")
   Set ol = ws.ListObjects("tbClient")
   Set olRng = ol.Range

   'remove table filters
   ol.ShowAutoFilter = False
  
   'get Valid column
    olCol = ol.ListColumns("Valid").Index

   'filter table
   ol.Range.AutoFilter field:=olCol, Criteria1:="<0", Operator:=xlOr
  
   'select table to copy
   Set olRng = ol.Range

   'create mail
   Call CreateMail
 
   'clear table filters
   ol.AutoFilter.ShowAllData
 
End Sub

Sub CreateMail()

    On Error GoTo errHandler

    Dim olCol As Integer, rCell As Range, addRng As Range
    Dim mailBcc As String, mailCC As String

    ' Outlook
    Dim OutApp As Object, OutInsp As Object, OutMail As Object

    'Declare Word Variables
    Dim oWrdDoc As Word.Document, oWdEditor As Word.Editors
    Dim sText As String
    
    'Range of mail adresses
    olCol = ol.ListColumns("Requestor email").Index
    Set addRng = ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
    
    'get the mail addresses
    For Each rCell In addRng
        mailBcc = mailBcc & rCell.Value & ";"
        mailCC = mailCC & rCell.Offset(0, 1).Value & ";"
    Next rCell

    ' copy table colmns B,J,L
    ws.Columns.Hidden = False
    ws.Range("A:A,C:I,K:K,M:Z").EntireColumn.Hidden = True
    olRng.Copy
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Dim signature As String
    With OutMail
        .display ' or send
        signature = .body
        .cc = mailCC
        .Bcc = mailBcc
        .Subject = "Generic Subject"
    End With

    ' Text
    sText = "The body text I want to put before the table" & vbCrLf & vbCrLf

    'Get the Active Inspector
    'Get the document within the inspector
    Set OutInsp = OutMail.GetInspector
    Set oWrdDoc = OutInsp.WordEditor
    With oWrdDoc
       .Content.Delete
       .Paragraphs.Add.Range.Text = sText
       .Paragraphs.Add.Range.Paste
       .Paragraphs.Add.Range.Text = signature
    End With
    ws.Columns.Hidden = False
    Application.CutCopyMode = False

exitRoutine:
    
    'clear
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set ws = Nothing
    Exit Sub
    
errHandler:
    'Open immediate window to see the error
    Debug.Print Err.Number, Err.Description
    Resume exitRoutine
    
End Sub