VBA Outlook 邮件正文不显示（可能是由于 table 通过 vba excel 粘贴到邮件正文）
VBA Outlook mail body does not display (probably due to table pasted into mail body via vba excel)
我目前正在开发一个 vba excel 宏来过滤特定的行（基于一列中的值），然后从过滤的行中复制特定的列并将它们粘贴为 table进入outlook邮件正文。
我希望将 table 粘贴到电子邮件正文中的文本之后。但是，似乎 table 是邮件正文中唯一的内容，我不能将文本放在 table 之前。
非常感谢您就如何在粘贴前显示电子邮件正文中的文本提出建议 table。我当前的：“OutMail.Body = “我想放在 table 之前的正文文本”不起作用。
编辑 1 = 根据 CDP1802 调整 + 添加移动行到存档功能
代码：
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
'Change values on Deactivation e-mail sent column
datCol = ol.ListColumns("Deactivation e-mail sent").Index
ol.ListColumns(datCol).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = Range("H1")
'clear table filters
ol.AutoFilter.ShowAllData
'Move rows to the Archive
Call MoveRows
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 = "Openings Tracker"
End With
' Text
sText = "Ladies and gentlemen," & 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
Sub MoveRows()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim O As Long
A = Worksheets("Test1").UsedRange.Rows.Count
B = Worksheets("Archive").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Test1").Range("O1:O" & A)
On Error Resume Next
Application.ScreenUpdating = False
For O = 1 To xRg.Count
If CStr(xRg(O).Value) = "OK" Then
xRg(O).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)
xRg(O).EntireRow.Delete
If CStr(xRg(O).Value) = "OK" Then
O = O - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
在word文档中添加一个段落。
update1 - 过滤器table，在末尾添加签名。
update2 - 仅显示列 B J L
update3 - 添加了 AchiveRows()
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
Sub ArchiveRows()
Dim ol As ListObject, rng As Range
Dim r As Long, olCol As Long, n As Long
Set ol = Sheets("Test1").ListObjects("tbClient")
olCol = ol.ListColumns("Valid").Index
With ol.DataBodyRange
For r = 1 To .Rows.Count
If UCase(Trim(.Cells(r, olCol).Value)) = "OK" Then
If rng Is Nothing Then
Set rng = .Rows(r)
Else
Set rng = Union(rng, .Rows(r))
End If
End If
Next
End With
If rng Is Nothing Then
n = 0
Else
n = rng.Rows.Count
With Sheets("Archive")
rng.Copy
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
.PasteSpecial xlPasteValues
End With
End With
rng.Rows.Delete
Application.CutCopyMode = False
End If
MsgBox n & " rows moved to Archive and deleted"
End Sub
我目前正在开发一个 vba excel 宏来过滤特定的行（基于一列中的值），然后从过滤的行中复制特定的列并将它们粘贴为 table进入outlook邮件正文。 我希望将 table 粘贴到电子邮件正文中的文本之后。但是，似乎 table 是邮件正文中唯一的内容，我不能将文本放在 table 之前。
非常感谢您就如何在粘贴前显示电子邮件正文中的文本提出建议 table。我当前的：“OutMail.Body = “我想放在 table 之前的正文文本”不起作用。
编辑 1 = 根据 CDP1802 调整 + 添加移动行到存档功能
代码：
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
'Change values on Deactivation e-mail sent column
datCol = ol.ListColumns("Deactivation e-mail sent").Index
ol.ListColumns(datCol).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = Range("H1")
'clear table filters
ol.AutoFilter.ShowAllData
'Move rows to the Archive
Call MoveRows
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 = "Openings Tracker"
End With
' Text
sText = "Ladies and gentlemen," & 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
Sub MoveRows()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim O As Long
A = Worksheets("Test1").UsedRange.Rows.Count
B = Worksheets("Archive").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Test1").Range("O1:O" & A)
On Error Resume Next
Application.ScreenUpdating = False
For O = 1 To xRg.Count
If CStr(xRg(O).Value) = "OK" Then
xRg(O).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)
xRg(O).EntireRow.Delete
If CStr(xRg(O).Value) = "OK" Then
O = O - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
在word文档中添加一个段落。
update1 - 过滤器table，在末尾添加签名。
update2 - 仅显示列 B J L
update3 - 添加了 AchiveRows()
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
Sub ArchiveRows()
Dim ol As ListObject, rng As Range
Dim r As Long, olCol As Long, n As Long
Set ol = Sheets("Test1").ListObjects("tbClient")
olCol = ol.ListColumns("Valid").Index
With ol.DataBodyRange
For r = 1 To .Rows.Count
If UCase(Trim(.Cells(r, olCol).Value)) = "OK" Then
If rng Is Nothing Then
Set rng = .Rows(r)
Else
Set rng = Union(rng, .Rows(r))
End If
End If
Next
End With
If rng Is Nothing Then
n = 0
Else
n = rng.Rows.Count
With Sheets("Archive")
rng.Copy
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
.PasteSpecial xlPasteValues
End With
End With
rng.Rows.Delete
Application.CutCopyMode = False
End If
MsgBox n & " rows moved to Archive and deleted"
End Sub