VBA：复制并粘贴电子邮件中的单元格，而不会丢失格式

我希望能够发送包含Excel电子表格单元格的电子邮件。 目前我有下面的代码插入我想要的电子邮件的范围，但我遇到的问题是，它删除了大部分的格式，例如字体的改变和一些条件格式被删除。

Sub EmailExtract() Dim objOutlook As Object Dim objMail As Object Dim TempFilePath As String Dim Location As String Dim Individual As String Dim rng As Range Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) Worksheets("Contacts").Activate Range("A2").Select While ActiveCell <> "" ActiveCell.Offset(1, 0).Select Location = ActiveCell.Address Individual = ActiveCell.Value Worksheets("Individual Output 2").Activate Range("C2").Value = Individual Set rng = ActiveSheet.Range("A1:M28").Rows.SpecialCells(xlCellTypeVisible) 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 objMail .To = "[e-mail]" .Subject = "" Dim Greeting As String If Time >= #12:00:00 PM# Then Greeting = "Afternoon ," Else Greeting = "Morning," End If .HTMLBODY = "<font face=Arial><p>" & "Good " + Greeting + "</p>" .HTMLBODY = .HTMLBODY + "<p>" & "Please find below your " & MonthName((Month(Date)) - 1) & " Information." & "</p>" .HTMLBODY = .HTMLBODY + RangetoHTML(rng) .HTMLBODY = .HTMLBODY + "<p>" & "Kind Regards" & "</p>" .HTMLBODY = .HTMLBODY + "<p>" & "Joe Bloggs" & "</p></font>" .Display End With Worksheets("Contacts").Activate Wend Set objOutlook = Nothing Set objMail = Nothing Set objOutlook = Nothing Set objMail = Nothing End Sub 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 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 

我想要的是能够通过电子邮件提取与格式应用，是否有可能这样做？ 也许把它作为一张图片粘贴到电子邮件中？

Answer 1

Ron de Bruin网站上的RangetoHTMLfunction对我来说一直效果不错。

你有没有检查电子邮件的BodyFormat属性？ 这可能是对Rich Text的默认设置。