使用 VBA 粘贴到 Outlook 中的位图始终为空白/白色答案

【问题标题】：Bitmap pasted into Outlook using VBA always blank/white使用 VBA 粘贴到 Outlook 中的位图始终为空白/白色
【发布时间】：2021-09-04 12:32:17
【问题描述】：

所以我有这段代码，它将在 excel 中捕获一个范围并将其导出，然后将其与一堆文本一起嵌入到电子邮件的正文中，但是除非我打开工作表，否则图像显示为白色/空白前面（我尝试添加代码以最大化窗口，但这不起作用）。

它似乎只在我一次运行一行时才有效。希望有人能在我迷路时帮助我

我的vba不是很擅长，只有一点点自学，所以看起来可能有点难看，对不起，如果有必要我会尝试解释更多。

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

【问题讨论】：

Saellie，您写道，代码在一次运行一行时运行良好。也许代码运行得比完全处理图表对象要快。因此，也许可以尝试在粘贴、导出和删除图表的代码中添加延迟。例如，Application.Wait Now + TimeSerial(0, 0, 5) 将添加 5 秒延迟。希望，这会有所帮助。
不幸的是没有运气添加延迟:(
Saellie，也许还可以尝试将DoEvents 添加到您的代码中。
@Saellie，在.Chart.Paste之前插入.Chart.Parent.Select

标签： excel vba outlook

【解决方案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

【讨论】：