通过邮件发送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将作为。显示，除了不显示更新之前。这个想法通常与生成默认签名有关，尤其是当与显示相关的闪光灯很烦人时。

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 = "[email protected]" 
     .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