在Outlook中粘贴excel范围

我正在尝试使用VBA将选定范围从Excel粘贴到Outlook。我想与所有收件人保持相同的对话

我看到了一些代码：

我被这段代码卡住了（

Application.ActiveExplorer.Selection

）

有什么办法吗

这是我创建新电子邮件而不是回复电子邮件时的代码：

Sub a()
Dim r As Range
Set r = Range("B1:AC42")
r.Copy

'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut



'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)

'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor

With outMail
.BodyFormat = olFormatHTML
  .Display
  '.HTMLBody = "write your email here" & "<br>" & .HTMLBody
  .Subject = ""
  .Attachments.Add ("path")


End With
'Paste picture
wordDoc.Range.Paste

For Each shp In wordDoc.InlineShapes
shp.ScaleHeight = 50 shp.ScaleWidth = 50
 Next

End Sub

suba（）
调光范围
设置r=范围（“B1:AC42”）
r、 抄袭
'将图片粘贴到工作表中并立即剪切
暗p为图片
设置p=ActiveSheet.Pictures.Paste
p、 削减
'打开新邮件项目
Dim outlookApp作为Outlook.Application
设置outlookApp=CreateObject（“Outlook.Application”）
将outMail设置为Outlook.MailItem
Set-outMail=outlookApp.CreateItem（olMailItem）
“获取其Word编辑器
发邮件。显示
Dim wordDoc作为Word.Document
设置wordDoc=outMail.GetInspector.WordEditor
发邮件
.BodyFormat=olFormatHTML
.展示
'.HTMLBody=“在这里写电子邮件”&“
”&.HTMLBody
.Subject=“”
.Attachments.Add（“路径”）
以
“粘贴图片
wordDoc.Range.Paste
对于wordDoc.InlineShapes中的每个shp
小刻度高度=50小刻度宽度=50
下一个
端接头

编辑：
我注意到你的问题已经被另一个用户编辑过了，现在关于你需要回复所有电子邮件的说法已经不复存在了。这可能是为了让你的问题更简单，但现在我的回答没有那么有意义了。我的回答还假设您已经拥有插入电子邮件所需的HTML代码。如果情况并非如此，您可能希望了解一下如何开始将范围转换为HTML代码。

---

您链接到的是Outlook VBA，因此您必须确保以不同的方式声明变量，因为在Excel VBA中，

应用程序

将引用Excel应用程序而不是Outlook

以下是您可以进行此操作的方法：

Sub ReplyAllWithTable()
    Dim outlookApp As Outlook.Application
    Set outlookApp = CreateObject("Outlook.Application")
    Dim olItem As Outlook.MailItem
    Dim olReply As MailItem ' ReplyAll

    Dim HtmlTable As String
    HtmlTable = "<table><tr><td>Test</td><td>123</td></tr><tr><td>123</td><td>test</td></tr></table>"

    For Each olItem In outlookApp.ActiveExplorer.Selection
    Set olReply = olItem.ReplyAll
    olReply.HTMLBody = "Here is the table: " & vbCrLf & HtmlTable & vbCrLf & olReply.HTMLBody
    olReply.Display

    'Uncomment next line when you're done with debugging
    'olReply.Send

    Next olItem
End Sub

解释：

在

ReplyAllWithTableAsPicture

过程中，我们基本上做了与第一个代码相同的事情，但我们现在将图像附加到电子邮件中，但将其保持“隐藏”，这样我们就可以将其包含在电子邮件正文中，而不必在人们收到电子邮件时的附件列表中。为了包含图像，我们使用

img

标记，源代码以“cid”开头，允许我们引用“隐藏”附件

由于图像必须是一个文件，因此我们使用

RangeToImage

过程从我们提供的范围生成图像文件。当前，该文件将始终以相同的名称保存在临时目录中，这意味着该文件将被覆盖。如果要保存这些图像文件的副本，请随意更改名称或在名称中添加日期。

使用邮件项目，而不是创建邮件项目

范例

---

你的代码

---

改为

---

谢谢你的回答！这就是我一直在寻找的。由于上面显示的代码发生了更改，在将我的图片粘贴到outlook时出现了错误（运行时错误“4605”：此命令不可用）。有没有办法解决此问题？也许，在粘贴之前，您仍然需要

显示

电子邮件。Pefect让它完全正常工作！知道如何保持过去的对话吗？到目前为止，它只从To:和CC:列中提取所有电子邮件地址，但当我从excel粘贴图片时，它不会提取过去的电子邮件。但是它可以在没有图片的情况下工作你的代码工作得很好非常感谢！你知道如何在发送新邮件时保留过去的邮件吗？当我附加图片文件时，它会消失。对不起，我是新加入的VBA@Dennis我在初始答案的底部添加了一个新的部分，以解决您关于粘贴为图像的问题。您真是太棒了，一切都很完美！非常感谢你的帮助！

Sub ReplyAllWithTableAsPicture()

    'REFERENCE:
    '- https://excel-macro.tutorialhorizon.com/excel-vba-send-mail-with-embedded-image-in-message-body-from-ms-outlook-using-excel/

    Dim outlookApp As Outlook.Application
    Set outlookApp = CreateObject("Outlook.Application")
    Dim olItem As Outlook.MailItem
    Dim olReply As MailItem ' ReplyAll


    Dim fileName As String
    Dim fileFullName As String
    fileFullName = Environ("temp") & "\Temp.jpg" 'CUSTOMIZABLE (make sure this file can be overwritten at will)
    fileName = Split(fileFullName, "\")(UBound(Split(fileFullName, "\")))

    RangeToImage fileFullName:=fileFullName, rng:=ActiveSheet.Range("B1:AC42") 'CUSTOMIZABLE (choose the range to save as picture)

    For Each olItem In outlookApp.ActiveExplorer.Selection 'if we have only one email, we could use: set olItem = outlookApp.ActiveExplorer.Selection(1)
    Set olReply = olItem.ReplyAll
    olReply.Attachments.Add fileFullName, olByValue, 0
    olReply.HTMLBody = "Here is the table: " & "<br>" & "<img src='cid:" & fileName & "'>" & vbCrLf & olReply.HTMLBody
    olReply.Display

    'Uncomment this line when you're done with debugging
    'olReply.Send

    Next olItem
End Sub

Sub RangeToImage(ByVal fileFullName As String, ByRef rng As Range)

    'REFERENCE:
    '- https://analystcave.com/excel-image-vba-save-range-workbook-image/

    Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
    Dim pic As Variant

    'Create temporary chart as canvas
    Set sht = rng.Worksheet
    rng.Copy
    sht.Pictures.Paste.Select
    Set sh = sht.Shapes(sht.Shapes.Count)
    Set tmpChart = Charts.Add
    tmpChart.ChartArea.Clear
    tmpChart.Name = "PicChart" & (Rnd() * 10000)
    Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
    tmpChart.ChartArea.Width = sh.Width
    tmpChart.ChartArea.Height = sh.Height
    tmpChart.Parent.Border.LineStyle = 0

    'Paste range as image to chart
    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste

    'Save chart image to file
    tmpChart.Export fileName:=fileFullName, FilterName:="jpg"

    'Clean up
    sht.Cells(1, 1).Activate
    sht.ChartObjects(sht.ChartObjects.Count).Delete
    sh.Delete

End Sub

Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)

'Get its Word editor
outMail.Display

Dim sel_Item As Outlook.MailItem
Set sel_Item = outlookApp.ActiveExplorer.Selection(1)    

Dim outMail As Outlook.MailItem
'Get its Word editor
Set outMail = sel_Item.ReplyAll