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

u可以这样尝试。

它检查插入的文本在何处停止并粘贴数据。

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

向Outlook中添加文本，Excel表和默认签名

2 个答案: