通过邮件发送Excel图表（Outlook）

Question

我找到了一个代码，可以将Excel中的一系列单元格转换为照片。 那张照片是通过邮件发送的。 问题是，当我使用.Display一切正常，但是当我使用.Send邮件发送空。

这是代码：

Sub Send_Pt_mail()

Dim OutApp As Object
Dim OutMail As Object
Dim Fname As String
Dim ch As ChartObject


'Prepare screen data file

Set ch = Worksheets("Chart").ChartObjects.Add(Range("Photo2Mail").Left, Range("Photo2Mail").Top, Range("Photo2Mail").Width, Range("Photo2Mail").Height)

'calculating the number of Recipients
iRow = Worksheets("Recipients").Cells(Rows.Count, 1).End(xlUp).Row
Recipients = ""
For i = 2 To iRow

'for each record in Recipients sheet an eMail will be send
If ThisWorkbook.Worksheets("Recipients").Cells(i, 2).Value = ThisWorkbook.Worksheets("Recipients").Cells(2, 7).Value Then
Recipients = Recipients & ThisWorkbook.Worksheets("Recipients").Cells(i, 1) & ";"
End If
Next i


'Prepare mail range as an image


Application.ScreenUpdating = True


    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)

    Fname = Environ$("temp") & "Mail_snap" & ".gif"

    'select the relevant table (update or new data) and export through Chart to file

    'then select the charts in dashboard and export through Chart 18 to file

    ch.Chart.ChartWizard Source:=Worksheets("DB").Range("Photo2Mail"), gallery:=xlLine, Title:="New Chart"

 '   ch.Chart.ChartArea.ClearContents

 '   ch.Width = 1700

 '   ch.Height = 900

    Chart_Name = ch.Name

    Worksheets("DB").Activate
    Range("Photo2Mail").Select

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

    Worksheets("Chart").ChartObjects(Chart_Name).Activate

    ActiveChart.Paste

    ActiveWorkbook.Worksheets("Chart").ChartObjects(Chart_Name).Chart.Export Filename:=Fname, FilterName:="gif"


        S = "<img src=" & Fname & "><br>"


    'On Error Resume Next

    With OutMail

        .To = Recipients

        .CC = ""

        .BCC = ""

        .Subject = ThisWorkbook.Worksheets("Recipients").Cells(3, 4) & "  " & Format(Now(), "dd/mm/yyyy")

        .Save

        .HTMLBody = S


             ' send

             .display


    End With

    On Error GoTo 0

    Kill Fname

    ch.Delete

StopMacro:


    Set OutMail = Nothing

    Set OutApp = Nothing

Application.ScreenUpdating = False
If (ActiveWindow.Zoom <> 100) Then

    ActiveWindow.Zoom = 100

End If

End Sub

Answer 1

如果邮件正文在发送之前没有更新，则.GetInspector将充当.Display，但不显示。 这个想法通常与生成默认签名有关，特别是当与显示器相关联的闪光灯很烦人时。

Sub Send_With_Signature_Demo()

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail

        .To = "myaddress@somewhere.com"
        .Subject = Format(Now(), "dd/mm/yyyy")

        ' If you have a default signature
        ' you should find you need either .GetInspector or .Display
        .GetInspector
        .Save

        .Send

    End With

StopMacro:
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub