Question

我需要将两张中的内容复制到Outlook邮件正文中。

工作表1仅包含带有一些合并单元格的文本。
Sheet2包含图表。

我失败的做法：

将sheet1和sheet2中的内容复制到临时表中然后将完整的内容从临时表复制到邮件正文。
这种方法混淆了一次完全对齐内容将粘贴到Outlook邮件正文中，即使它在临时表中看起来很好。

以下是我使用的代码段。

Sub copy_graph()
Dim outlookapp, outmail, worddoc As Object

Set outlookapp = CreateObject("outlook.application")
Set outmail = outlookapp.createitem(olmailitem)

outmail.display
Set worddoc = outmail.getinspector.wordeditor

ThisWorkbook.Sheets.Add.Name = "temp_mail"
ThisWorkbook.Worksheets("Tu_Mail").Range("a4:b18").Copy
ThisWorkbook.Worksheets("temp_mail").Range("a1").Select
ActiveSheet.Paste

ThisWorkbook.Worksheets("trend").Range("a1:x93").Copy
ThisWorkbook.Worksheets("temp_mail").Range("a19").Select
ActiveSheet.Paste

ThisWorkbook.Worksheets("temp_mail").Range("a1:x93").Copy
worddoc.Range.PasteExcelTable linkedtoexcel:=False, wordformatting:=False, RTF:=False
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("temp_mail").Delete

End Sub

有没有办法将两张纸中的内容逐个粘贴到邮件正文中，而不是将它们合并到一张表中。即粘贴为两个不同的表，以便列对齐完整。

或

还有其他更好的方法吗？

Answer 1

这是我最终工作的方法

<强>方法

将sheet1内容复制到临时表中   将sheet2（图表）内容复制到临时表作为图片。

现在，我已经知道将图表复制为图片了
我之前因为无法导出而一直忽略此方法将图表转换为高质量的图像，没有扭曲的文本和图形线。
在这种方法中，我使用了CopyPicture函数，此函数能够按原样获取图形内容，但是在图像中。

以下是我的最终代码

Sub copy_graph()

Dim rgExp As Range
Set outlookapp = CreateObject("outlook.application")
Set OutMail = outlookapp.createitem(olmailitem)
OutMail.display
Set worddoc = OutMail.getinspector.wordeditor

ThisWorkbook.Sheets.Add
ActiveSheet.Name = "temp"
ThisWorkbook.Worksheets("temp").Range("a:z").Delete
ThisWorkbook.Worksheets("temp").Columns("a:a").ColumnWidth = 25.57
ThisWorkbook.Worksheets("temp").Columns("b:b").ColumnWidth = 89.57

'Copy contents from sheet1
ThisWorkbook.Worksheets("Mail").Range("a5:b18").Copy
ThisWorkbook.Worksheets("temp").Range("a1").Select
ThisWorkbook.Worksheets("temp").Paste

'Copy contents from sheet2 as picture
Set rgExp = ThisWorkbook.Worksheets("graph").Range("a1:x93")
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
ThisWorkbook.Worksheets("temp").Range("a19").Select
ThisWorkbook.Worksheets("temp").Paste
ThisWorkbook.Worksheets("temp").Range("a1:t105").Copy
worddoc.Range.PasteExcelTable linkedtoexcel:=False, wordformatting:=False, RTF:=False

Application.DisplayAlerts = False

ThisWorkbook.Worksheets("temp").Delete

End Sub

将多个Excel工作表中的内容粘贴到Outlook正文

1 个答案: