将带有渐变填充单元格的Excel表复制到Outlook邮件

Question

我在Excel中有一个表格，我希望使用电子邮件正文中的表格将其发送到Outlook中的通讯组列表。

在这里使用MVP Ron de Bruin的示例和其他一些示例我已经有了一些代码可以保留一些表格格式但如果它是渐变则不会复制单元格颜色（请使用图像作为参考）。 / p>

Sub DisplayEmailButton_Click()
Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Sheet1").Range("C2:Q18").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 OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .To = "Team01"
    .CC = ""
    .BCC = ""
    .Subject = "Daily Statistics"
    .HTMLBody = "Please see attached daily statistics." & vbCrLf & 
     RangetoHTML(rng)
    .Display
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)

Dim TempFile As String, ddo As Long
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

' Temporary publish the rng range to a htm file
ddo = ActiveWorkbook.DisplayDrawingObjects
ActiveWorkbook.DisplayDrawingObjects = xlHide
With ActiveWorkbook.PublishObjects.Add( _
   SourceType:=xlSourceRange, _
   Filename:=TempFile, _
   Sheet:=ActiveSheet.Name, _
   Source:=Union(rng, rng).Address, _
   HtmlType:=xlHtmlStatic)
.Publish True
.Delete
End With
ActiveWorkbook.DisplayDrawingObjects = ddo

'Read all data from the htm file into RangetoHTML
With 
CreateObject("Scripting.FileSystemObject").GetFile(TempFile)
.OpenAsTextStream(1, -2)
RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left 
x:publishsource=")
.Close
End With

'Delete the htm file we used in this function
Kill TempFile

End Function

Answer 1

正如Tim所建议的那样，我对该程序的期望值过高（感谢Tim，您的建议！），所以我研究了一种解决方法。如果范围另存为图片，则它将保留所有格式，然后图片可以轻松地附加到电子邮件或显示在电子邮件正文中。

要另存为图片：

Dim Wb As ThisWorkbook
Dim Ws As Worksheet
Dim Ch As Chart

Set Rng = Ws.Range("A1:G18")
Set Ch = Charts.Add
Ch.Location xlLocationAsObject, "Sheet2"
Set Ch = ActiveChart
ActiveChart.Parent.Name = "StatsTemp"
ActiveSheet.ChartObjects("StatsTemp").Height = Rng.Height
ActiveSheet.ChartObjects("StatsTemp").Width = Rng.Width

Rng.CopyPicture xlScreen, xlBitmap
Ch.Paste
Ch.Export Environ("UserProfile") & "\Desktop" & "\" & Format("TempImage") & ".jpg"

Worksheets("Sheet2").ChartObjects("StatsTemp").Delete
Worksheets("Sheet1").Activate

上面的代码通过在工作表2上创建新图表将范围另存为图像“ TempImage.JPG”到用户桌面，将范围粘贴到图表，然后将图表另存为图像并删除图表。

要将图片附加到电子邮件正文中的电子邮件，请执行以下操作：

Dim StrBody As String
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

StrBody = "Some text here." & "<br>"

On Error Resume Next
With OutMail
    .to = "email address"
    .CC = ""
    .BCC = ""
    .Subject = "Email Subject"
    .HTMLBody = StrBody & "<img src = '" & Environ("userProfile") & 
    "\desktop\TempImage.jpg'>"
    .Display
End With
On Error GoTo 0

With Application
  .EnableEvents = True
  .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

以上代码使用Microsoft Outlook创建了一封电子邮件，其中在电子邮件正文中包含了已保存的图像文件并显示了该电子邮件。

使用后可以删除图像

Kill Environ("UserProfile") & "\Desktop" & "\TempImage.jpg"

希望这对某人有用！ 感谢Ron de Bruin的Microsoft Office MVP的WinTips！