将文本，Excel表格和默认签名添加到Outlook

Question

我有一个带有按钮的excel文件，当用户点击它时，应该打开一个带有特定excel表的outlook邮箱，邮件正文开头的几个文本行（在表之前）和我的默认签名（如在outlook中定义）也应该存在。 当我运行我的代码时，只有excel表正在邮件正文上（表格前所需的文本和签名丢失）。

请帮助，非常感谢

这是我的代码：

Sub SendCA_list()

Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")
Dim oMail As Object
Set oMail = oApp.CreateItem(olMailItem)

'select the table
Range("Table4[[#Headers],[Department]]").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWindow.SmallScroll Down:=-129
Selection.Copy


With oMail



.Body = "Hi All," & vbNewLine & "Enclosed below open A/Is list from last ISO Internal Audit. Please review and perform the required corrective actions." & vbNewLine & "Please update status and details in the audit report until next week."

Dim wordDoc As Object
Set wordDoc = oMail.GetInspector.WordEditor
wordDoc.Range.Paste

.Display

End With

Answer 1

你可以这样试试。

它会检查插入文本的停止位置并在之后粘贴数据。

With OutMail

 .Body = "Hi All," & vbNewLine & "Enclosed below open A/Is list from last ISO Internal Audit. Please review and perform the required corrective actions." & vbNewLine & "Please update status and details in the audit report until next week." & vbCrLf

 Dim wordDoc As Object
 Set wordDoc = OutMail.GetInspector.WordEditor

 wordDoc.Application.Selection.Start = Len(.Body)
 wordDoc.Application.Selection.End = Len(.Body)

 wordDoc.Application.Selection.Paste

 Display

End With

Answer 2

问题是我使用.body而不是.htmlbody。

这是正确的代码：

Sub SendCA_list()

Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")
Dim oMail As Object
Set oMail = oApp.CreateItem(olMailItem)

Range("Table4[[#Headers],[Department]]").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWindow.SmallScroll Down:=-129
Selection.Copy 'select and copy the required table

Dim rng As Range
Set rng = Selection.SpecialCells(xlCellTypeVisible) 'range of selected table

With oMail

.HtmlBody = "Hi All," & "<br>" & "Enclosed below open A/Is list from last ISO Internal Audit. Please review and perform the required corrective actions." & "<br>" & "Please update status and details in the audit report until next week." 

Dim wordDoc As Object
Set wordDoc = oMail.GetInspector.WordEditor

oMail.HtmlBody = .HtmlBody & "<br>" & RangetoHTML(rng) 'this is a function which paste the selected range to outlook mail in html format

.Display
End With

End Sub

插入范围从excel到html正文邮件的功能：

Function RangetoHTML(rng As Range)

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 xlPasteAllUsingSourceTheme, , 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)
RangetoHTML1 = ts.ReadAll
ts.Close
RangetoHTML1 = Replace(RangetoHTML1, "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