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

我在Excel中有一个表，我想将它发送到Outlook中的通讯组列表，并将该表放在电子邮件正文中

使用MVP Ron de Bruin的示例和其他一些示例，我得到了一些代码，这些代码保留了一些表格格式，但如果单元格颜色是渐变色，则不会复制单元格颜色（请使用图像作为参考）

---

正如蒂姆所说，我对这个过程的期望太高了（谢谢你，蒂姆，谢谢你的建议！），所以我寻找了一个解决办法。如果该范围保存为图片，则它将保留所有格式，然后可以轻松地将图片附加到电子邮件或显示在电子邮件正文中

要保存为图片，请执行以下操作：

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

希望这对某些人有用！

---

感谢Ron de Bruin的微软Office MVP WinTips

我认为您对这个过程的期望太高了——保存为HTML并不能保证创建源代码范围的完美副本。

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

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