使用VBA粘贴到Outlook中的Excel区域为空白/白色

Question

这段代码将在Excel中捕获一个范围，导出它，然后将其与文本一起嵌入到电子邮件的正文中。

图像显示白色/空白，除非我有工作表在前面打开。我试着添加代码来最大化窗口，但这不起作用。

只有当我一次运行一行时，它才能工作。

Public reportInterval As String
Public startBody As String
Public digitalBody As String
Public socroBody As String
Public fleetBody As String
Public loopBody As String
Public morningOrDay As String
Public picFile As String
Public picBody As String
Sub emailPic()
'===================================================
' Export Range as PNG file
'===================================================
' Set Range you want to export to file
Dim r As Range
Dim co As ChartObject
Workbooks(controlWS).Sheets(tempWS).Select
Set r = Range("A1:R133")
' Copy range as picture onto Clipboard
r.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
picFile = Environ("Temp") & "TempExportChart.png"
' Create an empty chart with exact size of range copied
Set co = r.Parent.ChartObjects.Add(Left:=r.Left, Top:=r.Top, Width:=r.Width, Height:=r.Height)
With co
' Paste into chart area, export to file, delete chart.
.Chart.Paste
.Chart.Export picFile
.Delete
End With
End Sub

Sub sendMail()
On Error GoTo ErrHandler
Dim objOutlook  As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail    As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
reportInterval = ""
Call emailPic
Call intervalFinder
Call morningOrDayFinder
Call htmlEmailBody
picBody = "<img src=""" & picFile & """ style=""width:304px;height:228px"">"
With objEmail
.Display
.SentOnBehalfOfName =
.To =
.CC = 
.Recipients.ResolveAll
.Subject = "Intraday Report: " & reportInterval
.HTMLBody = HTMLBody & startBody & digitalBody & socroBody & fleetBody & loopBody _
& picBody
End With
Set objEmail = Nothing:    Set objOutlook = Nothing
ErrHandler:
'
End Sub

Answer 1

问题是通过图表对象将图片文件创建为空白。我以前发现使用图表对象来保存图片的问题，在我不想要的地方添加边框，所以我使用发布者函数来保存图片。这需要添加一个引用。

更新保存图片的功能(您将需要重新编辑回您想要导出的工作表)

Sub emailPic()
' Requires reference: Microsoft Publisher x.x Object Library

'===================================================
' Export Range as PNG file
'===================================================
Dim r As Range
Dim picFile As String: picFile = Environ("Temp") & "TempExport.png"
If Dir(picFile) <> "" Then Kill picFile
With ThisWorkbook.Sheets("Sheet1")
Set r = .Range("A1:R133")
r.CopyPicture Appearance:=xlScreen, Format:=xlBitmap    ' Copy range as picture onto Clipboard
End With
Dim PubDoc As New Publisher.Document
PubDoc.Pages(1).Shapes.Paste
PubDoc.Pages(1).Shapes(1).SaveAsPicture _
PbResolution:=pbPictureResolutionCommercialPrint_300dpi, _
Filename:=picFile
PubDoc.Close
End Sub