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

Question

我想从我的Excel工作簿和默认签名的Sheep1中插入一个数据表。
我尝试使用HTMLBody，但它在显示表之前显示签名或根本没有显示。
我尝试更改.htmlbody的位置。

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

• to：
• cc：
• bcc：
• 主题：
• 正文：应该包含"嗨，请在下面找到详细信息＆quot"
• 然后具有范围数据（'a3：f3）数据的Excel表
• 然后我的签名（这是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

Answer 1

您可以通过

处理电子邮件的身体

Outlook.createitem（Olmailitem）.getInspector.wordeditor.range

因此，遵循简单的代码段

• 保留新电子邮件的标准签名
• 将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常数替换数字。

Answer 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

Answer 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:UserschipzAppDataRoamingMicrosoftSignatureschipz_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