Diagramme in E-Mail-Body als grafik einfügen

[Blacko]

Hallo,

ich habe eine Datei welche in mehreren Tabellenblättern Diagramme beinhaltet. Ich möchte nun einen wöchentlich zu verschickenden Bericht teilautomatisieren, indem aus der Datei mittels Makro eine Email erstellt wird, Empfänger eingetragen sind, Betreff und Text eingefügt werden und mehrere Diagramme (es sind jede Woche die selben) aus den Tabellenblättern automatisch in den E-Mailtext eingefügt werden. Heute passiert das manuell und es werden die Diagramme als Grafik in die E-Mail kopiert.

Ich habe mit untenstehendem Code 80% des Vorhabens erfolgreich umsetzen können, nur habe ich bei meinen bisherigen Recherchen keine passende Funktion gefunden wie ich die Diagramme in den Textbody einbette.

Code:

Sub EMail()

Dim objOutlook As Object
Dim objMail As Object

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
   .To = "Vorname.name@domain.de; Vorname2.name2.@domain.de"
   .Subject = "Diagramme Fehlerentwicklung"
   .Body = "Hallo," & vbLf & vbLf & "im Folgenden die aktualisierten Auswertungen:" & vbLf & vbLf
   
     
   .Display       
End With

End Sub


gefühlt müsste das doch recht simpel zu erreichen sein. Ich finde aber keine funktionierende Lösung.

Ich hoffe mir kann jemand helfen.

Vielen Dank um Voraus

[schauan]

Hallöchen,

hier mal ein Ansatz. Relevant fuer Dich ist eigentlich nur der Aufruf zum Bild erzeugen und das einfügen in einen - wichtig - html-Body. Ein Textbody würde generell nur Texte erlauben und Bilder nur als Anhang.
In dem im Code verlinkten Beitrag wird ein Bereich als Bild kopiert. Das kannst Du natürlich auf das Diagramm beschränken ...

Code:

Private Sub MachMal_Bild()
'Variablendeklarationen
Dim strPict As String
Dim objOut As Object, objMsg As Object
'Outlook starten
'- ggf. mit GetObject auf vorhandene Instanz zugreifen
Set objOut = CreateObject("Outlook.Application")
'neue E-Mail erzeugen
Set objMsg = objOut.CreateItem(0)
'Bildablege festlegen
strPict = "C:\temp\testgr2.gif"
'Bilderzeugung aufrufen
'code siehe https://www.clever-excel-forum.de/Thread-Unterschiede-W7-2010-13-zu-W10-2016?pid=69849#pid69849
Call testgrexpo
'Mit der Nachricht
With objMsg
    'an
    .To = "willi@bald.de"
    'Betreff
    .Subject = "Bild einfuegen"
    'Bilddatei unsichtbar anhaengen
    .Attachments.Add strPict, 1, 0
    'Text und Link auf angehaengte Bilddatei zur Anzeige
    .HTMLBody = "Hallo,<br><br>hier siest Du das Bild.<br><br>" & _
                "<img src='cid:testgr2.gif'" & "<br><br>"
    'Email anzeigen
    .Display
End With
'temporaere Bilddatei von Speichermedium loeschen
Kill strPict
End Sub

[volti]

Hallo Blacko,

hier mal eine Idee, wie Du eine eMail mit eingebetteter Grafik, Signatur und ggf. Anlage versenden kannst:

Sub SendeMailMitWordEditor()
'Sub sendet eine Mail mit Ausschnitten aus Excelsheet und Signatur via Word-Editor
 Dim sMailtext As String
 sMailtext = "Hallo," & vbLf & vbLf _
           & "im Folgenden die aktualisierten Auswertungen:" & vbLf & vbLf  'Bodytext
 With CreateObject("Outlook.Application").CreateItem(0)
  .Getinspector
  .Subject = "Diagramme Fehlerentwicklung"
  .body = sMailtext & .body
  .Importance = 1
  .To = "Vorname.name@domain.de; Vorname2.name2.@domain.de"
  .CC = ""
' .Attachments.Add sMyDatei
  .display
  With .Getinspector.WordEditor.Application.Selection
    ActiveSheet.Shapes.Range(Array("Picture 1")).Select
    Selection.Copy
    .Start = Len(sMailtext)
    .End = Len(sMailtext)
    .Paste
  End With
 End With
End Sub

viele Grüße
Karl-Heinz

[schauan]

feine Lösung

[volti]

Danke für die nette Rückmeldung Schauan.

Klar habe ich hier auch Versionen mit u.a. Range2HTML, je nach Zweck. Diese Lösung scheint mir hier aber am günstigsten zu sein.

Hier, auch für den Fragesteller, noch zwei Hinweise:

Mehrere Diagramme einfügen (werden aber aneinander geklatscht)
ActiveSheet.Shapes.Range(Array("Chart 4", "Chart 1")).Select
Selection.copy

Oder ganzen Range kopieren (ggf. Zellen incl. und/oder Grafiken, Ansicht wie in Excel)
ActiveSheet.Range("A1:M25").Copy

VG KH

[Blacko]

Hallo,

also erstmal danke für die Lösungen.

Habe gerade die Lösung von dir Karl-Heinz ausprobiert. Ist schon fast das was ich wollte. In deinem Beispiel bekomme ich aber nur ein Diagramm von aktiven Blatt eingefügt. Ich habe jetzt mehrere Diagramme auf mehreren Tabellenblättern. Hab versucht den Code entsprechend anzupassen (z.B. mit ActiveWorkbook etc.) aber das hat nicht funktioniert.
Sollte ja eigentlich nicht so schwer sein, das noch einzubauen, ich komm aber nicht drauf. Hast du dafür noch eine Lösung?

Gruß

[volti]

Hallo Blacko,

hier eine Idee zu Deiner Anfrage.

Man kann natürlich auf einem Blatt auch gleich mehrere Bilder gleichzeitig markieren, geht aber mit meiner Unterprogrammlösung schwerlich.
Die Mehrfachkopiererei sollte aber keine Probleme machen...

Sub SendeMailMitWordEditor2()
'Sub sendet eine Mail mit Ausschnitten aus Excelsheet und Signatur via Word-Editor
 Dim sMailtext As String, sBlatt As String, sPic As String, oRette As Worksheet
 Application.ScreenUpdating = False
 sMailtext = "Hallo," & vbLf & vbLf _
           & "im Folgenden die aktualisierten Auswertungen:" & vbLf & vbLf  'Bodytext
 With CreateObject("Outlook.Application").CreateItem(0)
  .Getinspector
  .Subject = "Diagramme Fehlerentwicklung"
  .body = sMailtext & .body
  .Importance = 1
  .To = "Vorname.name@domain.de; Vorname2.name2.@domain.de"
  .CC = ""
' .Attachments.Add sMyDatei
  .display
  Set oRette = ActiveSheet
'Bilder/Diagramme in verschiedenen Blättern
  sBlatt = "Ziel":        sPic = "Picture 1": GoSub UP
  sBlatt = "MeineHerber": sPic = "Chart 2":   GoSub UP
  sBlatt = "Mail":        sPic = "Picture 1": GoSub UP
  oRette.Select
  Application.ScreenUpdating = True
  Exit Sub

UP:
  With .Getinspector.WordEditor.Application.Selection
    Sheets(sBlatt).Select
    ActiveSheet.Shapes.Range(Array(sPic)).Select
    Selection.Copy
    .Start = Len(sMailtext)
    .End = Len(sMailtext)
    .Paste
  End With
  Return
 
 End With
End Sub

viele Grüße
Karl-Heinz

[Blacko]

Hallo Karl-Heinz,

mega!!!!!

exakt das was ich wollte.

Vielen Dank dafür.

Gruß