メールでExcelチャートを送信する（Outlook）

Question

Excelのセル範囲を写真に変えるコードが見つかりました。その写真は郵送で送付されます。問題は、私が.Displayを使用しているときはすべてOKですが、私が.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