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

Posted 2023-04-19

【中文标题】从 Excel 工作表插入数据表后插入默认签名

【英文标题】：Insert default signature after inserting a table of data from an Excel sheet

【发布时间】：2019-03-03 08:12:09

【问题描述】：

我想从我的 Excel 工作簿的 Sheet1 和我的默认签名中插入一个数据表。 我尝试使用 htmlBody，但它要么在表格显示之前显示签名，要么根本不显示任何内容。 我尝试改变 .HTMLBody 的位置。

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

收件人： 抄送： 密件抄送： 主题： 正文：应包含“Hi Please find below the details” 然后是 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 = "[e-mail]"
    .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

【问题讨论】：

你有没有考虑过把它和桌子一起放在床单上，然后一次性移动它？

是的，试过了。但它没有成功。

如何将多个电子邮件地址添加到To，请参阅此处获取灵感：***.com/q/54219147/10908769

【参考方案1】：

您可以通过以下方式处理您的电子邮件正文

Outlook.CreateItem(olMailItem).GetInspector.WordEditor.Range

所以遵循简单的代码sn-p

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

---

With pageEditor.Range
    .Collapse 1   ' wdCollapseStart
    .InsertBefore "Hi Please find below the details" & vbCrLf
    .Collapse 0   ' wdCollapseEnd
    .InsertAfter "Text before signature" & vbCrLf
    .Collapse 1   ' wdCollapseStart

    Sheet1.Range("B3:F3").Copy
    .Paste
    '.PasteAndFormat 13  ' wdChartPicture
    '.PasteAndFormat 22  ' wdFormatPlainText
End With

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

【参考方案2】：

您可以使用我的代码如下

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

【参考方案3】：

这对我有用

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 = "[e-mail]"
    .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

【讨论】：

是的，现在可以使用了.... 非常感谢。我是这方面的新手。所以我在这个十字路口。尝试了很多东西。谢谢你是一个救生员。

再问一个简单的问题。如何在 Excel 工作表的收件人列表中添加多个地址？

@Chipz 您必须遍历包含电子邮件地址的单元格范围并与; 连接。请参考我最近的帖子 ***.com/questions/54914673/…> 了解更多详情。如有困难，请提出新问题。

是的，现在它正在工作。我没有考虑串联。非常感谢。！！！！你真的帮了我很多。