我正在尝试使用 VBA 在电子邮件中发送 Excel 范围的屏幕截图,但是当它粘贴屏幕截图时,它会删除签名。 我还有其他工作表可以发送范围并保持签名很好,但附加图像似乎会导致问题。
Sub send_email_with_table_as_pic()
Dim OutApp As Object
Dim OutMail As Object
Dim table As Range
Dim pic As Picture
Dim ws As Worksheet
Dim wordDoc
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'grab table, convert to image, and cut
Set ws = ThisWorkbook.Sheets("XXX")
Set table = ws.Range("A1:J31")
ws.Activate
table.Copy
Set pic = ws.Pictures.Paste
pic.Cut
'create email message
On Error Resume Next
With OutMail
.To = "[email protected]"
.Cc = "[email protected]"
.BCC = ""
.Subject = "XXXXX " & Format(Now - 1, "mm-dd-yy")
.Display
Set wordDoc = OutMail.GetInspector.WordEditor
With wordDoc.Range
.PasteandFormat wdChartPicture
.InsertBefore ""
.insertParagraphBefore
.InsertAfter ""
.insertParagraphAfter
End With
.HTMLBody = "Hello, <Tab> Please see the below: <Tab> " & .HTMLBody
End With
On Error GoTo 0
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
有一件事需要保留签名。像这样定义插入点的范围:
With wordDoc.Range(1, 1)
Sub send_email_with_table_as_pic()
Dim OutApp As Object
Dim OutMail As Object
Dim table As Range
Dim pic As Picture
Dim ws As Worksheet
Dim wordDoc
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'grab table, convert to image, and cut
Set ws = ThisWorkbook.Sheets("XXX")
Set table = ws.Range("A1:J31")
ws.Activate
table.Copy
Set pic = ws.Pictures.Paste
pic.Cut
'create email message
On Error Resume Next
With OutMail
.To = "[email protected]"
.Cc = "[email protected]"
.BCC = ""
.Subject = "XXXXX " & Format(Now - 1, "mm-dd-yy")
.Display
Set wordDoc = OutMail.GetInspector.WordEditor
With wordDoc.Range(1, 1) 'edited
.PasteandFormat wdChartPicture
.InsertBefore ""
.insertParagraphBefore
.InsertAfter ""
.insertParagraphAfter
End With
.HTMLBody = "Hello, <Tab> Please see the below: <Tab> " & .HTMLBody
End With
On Error GoTo 0
Set OutApp = Nothing
Set OutMail = Nothing
End Sub