从Excel工作表插入数据表后插入默认签名

我想从Excel工作簿的Sheet1和默认签名中插入数据表。
我尝试使用HTMLBody，但它在显示表格之前显示签名，或者根本不显示签名。
我试图改变.HTMLBody的位置

我必须发送以下格式的邮件：

• 致：
• 抄送：
• 密件抄送：
• 主题：
• 正文：应包含“您好，请在下面查找详细信息”
• 然后是Excel表格，数据范围为（“A3:F3”）
• 然后是我的签名（Outlook中的默认签名或可以创建的签名）
• 并发送

下面是代码

Sub esendtable()

Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

With newEmail
    .To = "avc@123.com"
    .CC = ""
    .BCC = ""
    .Subject = "Data - " & Date
    .Body = "Please find below the data"
    .Display

    Set xInspect = newEmail.GetInspector
    Set pageEditor = xInspect.WordEditor
    Sheet1.Range("B3:F3").Copy

    pageEditor.Application.Selection.Start = Len(.Body)
    pageEditor.Application.Selection.End =     
    pageEditor.Application.Selection.Start
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
    .Display
    '.Send
    Set pageEditor = Nothing
    Set xInspect = Nothing
End With

Set newEmail = Nothing
Set outlook = Nothing

End Sub

这对我有用

Sub esendtable()

Dim rng As Range
Dim Outlook As Object
Dim newEmail As Object
Dim SigString As String
Dim Signature As String
Dim xInspect As Object
Dim pageEditor As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = ActiveSheet.Range("A3:F3")
' You can also use a range with the following statement.
 Set rng = Sheets("YourSheet").Range("A3:F3").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If

With Application
.EnableEvents = False
.ScreenUpdating = False
End With


Set Outlook = CreateObject("Outlook.Application")
Set newEmail = Outlook.CreateItem(0)

SigString = "C:\Users\chipz\AppData\Roaming\Microsoft\Signatures\chipz_1.htm" ' Change chipz in path and signature file name

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

On Error Resume Next
With newEmail
    .To = "recipient@test.com"
    .CC = ""
    .BCC = ""
    .Subject = "Data - " & Date
.BodyFormat = olFormatHTML
.HTMLBody = RangetoHTML(rng) & "" & Signature

.Display
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
'.Send
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With


Set newEmail = Nothing
Set Outlook = Nothing
Set newEmail = Nothing
Set Outlook = Nothing

End Sub
Function RangetoHTML(rng As Range)
' Ron de Bruin 
' 
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

子esendtable（）
变暗rng As范围
作为对象的暗淡前景
将新电子邮件作为对象
字符串作为字符串
作为字符串的数字签名
作为对象的Dim xInspect
将页面编辑器设置为对象
设置rng=无
出错时继续下一步
'仅发送所选内容中的可见单元格。
设置rng=ActiveSheet.Range（“A3:F3”）
'您还可以将范围与以下语句一起使用。
设置rng=工作表（“您的工作表”）。范围（“A3:F3”）。特殊单元格（xlCellTypeVisible）
错误转到0
如果rng不算什么，那么
MsgBox“所选内容不是范围或工作表受保护。" & _
vbNewLine&“请更正并重试。”，vbOKOnly
出口接头
如果结束
应用
.EnableEvents=False
.ScreenUpdate=False
以
设置Outlook=CreateObject（“Outlook.Application”）
设置newEmail=Outlook.CreateItem（0）
SigString=“C:\Users\chipz\AppData\Roaming\Microsoft\Signatures\chipz_1.htm”'更改chipz的路径和签名文件名
如果Dir（SigString）“，则
Signature=GetBoiler（SigString）
其他的
Signature=“”
如果结束
出错时继续下一步
用新邮件
.To=”recipient@test.com"
.CC=“”
.BCC=“”
.Subject=“数据-”和日期
.BodyFormat=olFormatHTML
.HTMLBody=RangetoHTML（rng）&“&签名
.展示
'代替下面的语句，您可以使用“.Display”来
'显示电子邮件消息。
’发送
以
错误转到0
应用
.EnableEvents=True
.ScreenUpdate=True
以
设置newEmail=Nothing
设置Outlook=Nothing
设置newEmail=Nothing
设置Outlook=Nothing
端接头
函数RangetoHTML（rng作为范围）
“罗恩·德·布鲁因
' 
作为对象的Dim fso
将T作为对象
将文件设置为字符串
将TempWB设置为工作簿
TempFile=Environ$（“temp”）和“\”格式（现在是“dd-mm-yy h-mm-ss”）和“.htm”
'复制范围并创建一个新工作簿，以超过中的数据
收到
Set TempWB=工作簿。添加（1）
带临时工作表（1）
.单元格（1）.粘贴特殊粘贴：=8
.单元格（1）.粘贴特殊值，False，False
.单元格（1）.粘贴特殊xlPasteFormats，False，False
.单元格（1）。选择
Application.CutCopyMode=False
出错时继续下一步
.DrawingObjects.Visible=True
.DrawingObjects.Delete
错误转到0
以
'将工作表发布到htm文件
使用TempWB.PublishObjects.Add（_
SourceType:=xlSourceRange_
文件名：=临时文件_
工作表：=临时工作表（1）.名称_
来源：=TempWB.Sheets（1）.UsedRange.Address_
HtmlType:=xlHtmlStatic）
.发布（真实）
以
'将htm文件中的所有数据读入RangetoHTML
设置fso=CreateObject（“Scripting.FileSystemObject”）
设置ts=fso.GetFile（TempFile）.OpenAsTextStream（1，-2）
RangetoHTML=ts.readall
关闭
RangetoHTML=Replace（RangetoHTML，“align=center x:publishsource=”_
“align=left x:publishsource=”）
“关闭TempWB
TempWB.Close savechanges:=False
'删除此函数中使用的htm文件
杀死临时文件
设置ts=无
设置fso=无
设置TempWB=Nothing
端函数
函数GetBoiler（ByVal sFile作为字符串）作为字符串
作为对象的Dim fso
将T作为对象
设置fso=CreateObject（“Scripting.FileSystemObject”）
设置ts=fso.GetFile（sFile）.OpenAsTextStream（1，-2）
GetBoiler=ts.readall
关闭
端函数

您可以通过

Outlook.CreateItem（olMailItem）.GetInspector.WordEditor.Range

下面是简单的代码片段

• 保留新电子邮件的标准签名
• 将Excel范围粘贴为范围、图片或纯文本
• 在Excel范围之前和/或它与签名之间添加文本

---

---

如果为早期绑定添加对“Microsoft Word x.x对象库”（和“Microsoft Outlook x.x对象库”）的引用，则可以用相应的Word枚举常量替换这些数字。

您可以按如下方式使用我的代码

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

With newEmail
.display
signature = newEmail.HTMLBody
sig = HtmlToText(signature)

.To = ""
.CC = ""
.Subject = "Test"
.HTMLBody = "Dear team," & "<br>" & "<br>" & "Please check and fix the issue below. Thank you!"

Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor

wb.Sheets(1).Range("a1:h" & lr).SpecialCells(xlCellTypeVisible).Copy
pageEditor.Application.Selection.Start = Len(.body)
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat (wdformatplaintext)
.display

.HTMLBody = .HTMLBody & signature
Set pageEditor = Nothing
Set xInspect = Nothing

End With

Set outlook=CreateObject（“outlook.Application”）
设置newEmail=outlook.CreateItem（0）
用新邮件
.展示
签名=newEmail.HTMLBody
sig=HTMLTOXT（签名）
.To=“”
.CC=“”
.Subject=“测试”
.HTMLBody=“亲爱的团队，&”
“&”
“&”请检查并解决以下问题。非常感谢。"
设置xInspect=newEmail.GetInspector
设置pageEditor=xInspect.WordEditor
wb.Sheets（1）.范围（“a1:h”和lr）.特殊单元格（xlCellTypeVisible）.复制
pageEditor.Application.Selection.Start=Len（.body）
pageEditor.Application.Selection.End=pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat（WDFormat纯文本）
.展示
.HTMLBody=.HTMLBody和签名
设置页面编辑器=无
设置xInspect=Nothing
以

你有没有考虑过把它和桌子一起放在工作表上，然后一次移动它？是的，试过了。但是没有成功。如何在

中添加多个电子邮件地址到
，请看这里获得灵感：是的，现在可以了……非常感谢。我是这方面的新手。所以我正处在十字路口。尝试了很多东西。谢谢你你是个救命恩人。还有一个简单的问题。如何在excel工作表的“收件人”列表中添加多个地址？@Chipz你必须在包含ema的单元格范围内循环
Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

With newEmail
.display
signature = newEmail.HTMLBody
sig = HtmlToText(signature)

.To = ""
.CC = ""
.Subject = "Test"
.HTMLBody = "Dear team," & "<br>" & "<br>" & "Please check and fix the issue below. Thank you!"

Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor

wb.Sheets(1).Range("a1:h" & lr).SpecialCells(xlCellTypeVisible).Copy
pageEditor.Application.Selection.Start = Len(.body)
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat (wdformatplaintext)
.display

.HTMLBody = .HTMLBody & signature
Set pageEditor = Nothing
Set xInspect = Nothing

End With