E-Mail versenden mit VBA

[Sabotaz]

Hallo,

Ja... Was soll ich sagen? Entgegen meiner generellen Haltung gegenüber VBA möchte ich nun doch zumindest die Funktion "E-Mail versenden" mit VBA realisieren. Das wäre der erste Grund, die Datei als .xlsm zu speichern.

Nun habe ich mir aus dem Netz verschiedene Codes zusammengesammelt und irgendwie rausklambüsert, wie ich was anpasse, damit es mit meiner Verwendung passt, es bleiben aber immer noch sehr viele Fragen offen, deren Antworten ich nicht im Netz gefunden habe:

1. Wie bekomme ich es hin, dass keine leeren Spalten und Zeilen in die Email übernommen werden? Aktuell habe ich eine dynamische Tabelle, die bis Zeile 1000 reicht, aber manchmal nur 20 Zeilen gefüllt sind, manchmal auch 40... Dementsprechend wären in der Mail 960 bis 980 Zeilen leer und die Mail wird unnötig lang. Gibt es da eine Möglichkeit, die leeren Zeilen wegzulassen?

2. Ich stand am Anfang vor dem Problem, dass die Tabelle als ein Text in Outlook angezeigt wurde, statt als Tabelle. Das Problem ist an sich behoben (*Modul2), allerdings ist die Darstellung immer noch eine andere, als wenn ich die Tabelle händisch kopiere und einfüge (händisch ist es deutlich besser, da die Formatierungen übernommen werden, was aktuell mit dem Makro nicht der Fall ist). Ich hab gedacht, dass ich das irgendwie mit der Zwischenablage realisieren könnte (*Modul1), aber das funktioniert überhaupt nicht, dort wird gar kein Inhalt angezeigt.
Folgend die Bilder, wie es aktuell aussieht und wie es wunderschön aussehen sollte:

Aktuell:
   

Ziel:
   

Modul1 (funktioniert gar nicht - leere Email)

Code:

Sub EMailVersendenModul1()
    Dim rng As Range
    Dim emailAdresse As String
    Dim mailApp As Object
    Dim mailItem As Object
   
    ' Definieren Sie den Bereich A1:F12 auf Tabellenblatt1
    Set rng = ThisWorkbook.Sheets("Tabelle1").Range("A1:F20")
   
    ' Holen Sie die E-Mail-Adresse aus Zelle A1 auf Tabellenblatt2
    emailAdresse = ThisWorkbook.Sheets("Daten").Range("B1").Value
   
    ' Kopieren Sie den Bereich in die Zwischenablage
    rng.Copy
   
    ' Erstellen Sie eine neue E-Mail
    Set mailApp = CreateObject("Outlook.Application")
    Set mailItem = mailApp.CreateItem(0)
   
    ' Fügen Sie den kopierten Bereich als Text in den E-Mail-Body ein
    mailItem.Body = "Hier ist der kopierte Bereich aus Tabellenblatt1:" & vbNewLine & vbNewLine & _
                    rng.Text
                   
    ' Setzen Sie die E-Mail-Adresse und den Betreff
    mailItem.To = emailAdresse
    mailItem.Subject = ThisWorkbook.Sheets("Daten").Range("B2").Value
   
    ' Senden Sie die E-Mail
    mailItem.Display
   
    ' Bereinigen
    Set mailItem = Nothing
    Set mailApp = Nothing
End Sub

Modul2 (funktioniert mit falscher Darstellung und Anzeige leerer Zeilen):

Code:

Sub EmailVersendenMitFormatierungModul2()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim MailAdresse As String
    Dim MailBetreff As String
    Dim MailInhalt As String
    Dim rng As Range
    Dim ws As Worksheet
    Dim i As Long, j As Long
   
    ' Arbeitsblatt mit den Daten
    Set ws = ThisWorkbook.Sheets("Tabelle1")
    ' Inhalt der E-Mail (Tabelle A1:F12 mit HTML-Formatierung)
    Set rng = ws.Range("A1:F20")
   
    ' E-Mail-Adresse aus Zelle Z10
    MailAdresse = ThisWorkbook.Sheets("Daten").Range("B1").Value
   
    ' Betreff der E-Mail
    MailBetreff = ThisWorkbook.Sheets("Daten").Range("B2").Value
   
    ' HTML-Tabelle erstellen
    MailInhalt = "<table border='1' cellpadding='5'>"
    For i = 1 To rng.Rows.Count
        MailInhalt = MailInhalt & "<tr>"
        For j = 1 To rng.Columns.Count
            MailInhalt = MailInhalt & "<td>" & rng.Cells(i, j).Value & "</td>"
        Next j
        MailInhalt = MailInhalt & "</tr>"
    Next i
    MailInhalt = MailInhalt & "</table>"
   
    ' Outlook-Objekt erstellen
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
   
    With OutlookMail
        .To = MailAdresse
        .Subject = MailBetreff
        .HTMLBody = "Liste aktueller Aufträge<br><br>" & MailInhalt
        .Display ' Display Zum Anzeigen der E-Mail vor dem Senden
        '.Send ' Zum direkten Senden der E-Mail
    End With
   
    ' Objekte freigeben
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Hier die Testdatei, welche ich aktuell verwende...

  Test Mail.xlsm (Größe: 34,47 KB / Downloads: 7)

Vielen Dank schonmal!

[BoskoBiati]

Hi,

versuche es mal so:

Code:

Sub EmailVersendenMitFormatierungModul2()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim MailAdresse As String
    Dim MailBetreff As String
    Dim MailInhalt As String
    Dim rng As Range
    Dim ws As Worksheet
    Dim i As Long, j As Long
    Dim loA As Long
    Dim loB As Long
    loA = Cells(Rows.Count, 1).End(xlUp).Row
    loB = Cells(3, Columns.Count).End(xlToLeft).Column
    ' Arbeitsblatt mit den Daten
    Set ws = ThisWorkbook.Sheets("Tabelle1")
    ' Inhalt der E-Mail (Tabelle A1:F12 mit HTML-Formatierung)
    Set rng = ws.Range("A1:F" & loA)
  
    ' E-Mail-Adresse aus Zelle Z10
    MailAdresse = ThisWorkbook.Sheets("Daten").Range("B1").Value
  
    ' Betreff der E-Mail
    MailBetreff = ThisWorkbook.Sheets("Daten").Range("B2").Value
  
    ' HTML-Tabelle erstellen
    MailInhalt = "<table border='1' cellpadding='5'>"
    For i = 1 To loA
        MailInhalt = MailInhalt & "<tr>"
        For j = 1 To loB
            MailInhalt = MailInhalt & "<td>" & rng.Cells(i, j).Value & "</td>"
        Next j
        MailInhalt = MailInhalt & "</tr>"
    Next i
    MailInhalt = MailInhalt & "</table>"
  
    ' Outlook-Objekt erstellen
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
  
    With OutlookMail
        .To = MailAdresse
        .Subject = MailBetreff
        .HTMLBody = "Liste aktueller Aufträge<br><br>" & MailInhalt
        .Display ' Display Zum Anzeigen der E-Mail vor dem Senden
        '.Send ' Zum direkten Senden der E-Mail
    End With
  
    ' Objekte freigeben
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

[Sabotaz]

Danke schonmal!

Das Ergebnis ist jetzt allerdings komplett leer :D

   

[volti]

Hallo Sabotanz,

Du baust per Html-Tags eine Tabelle nach. Kann man machen, wenn allerdings Schriftarten, Hintergründe usw. auch gebraucht werden, muss man deutlich mehr machen.

Besser ist es z.B die Range zu kopieren und über den  Wordeditor in die Mail als Bereich oder als Bild einzufügen 
oder RangeToHtml bzw. Range2Html zu benutzen.

Bin den Tag über nicht am PC, kann daher z. Zt. nicht weiterhelfen.
Ich habe aber u.a. auch hier im Forum etliche Beiträge zum Thema.

Ansonsten einfach mal die Stichworte googeln.

Gruß Karl-Heinz

[mumpel]

Hallo!

Dieser Code hat sich bewährt.

PHP-Code:

Function RangeToHTML(rng As Range)
Dim Fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangeToHTML = ts.readall
ts.Close
RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set Fso = Nothing
Set TempWB = Nothing
End Function


Gruß, René

[Sabotaz]

Hallo Sabotanz,

Du baust per Html-Tags eine Tabelle nach. Kann man machen, wenn allerdings Schriftarten, Hintergründe usw. auch gebraucht werden, muss man deutlich mehr machen.

Besser ist es z.B die Range zu kopieren und über den  Wordeditor in die Mail als Bereich oder als Bild einzufügen 
oder RangeToHtml bzw. Range2Html zu benutzen.

Bin den Tag über nicht am PC, kann daher z. Zt. nicht weiterhelfen.
Ich habe aber u.a. auch hier im Forum etliche Beiträge zum Thema.

Ansonsten einfach mal die Stichworte googeln.

Gruß Karl-Heinz

Danke für die Erklärung! So in etwa habe ich mir das auch vorgestellt, was da im Hintergrund passiert. Deshalb dachte ich, könnte ich ein Copy Paste nachbilden, aber so einfach ist es scheinbar nicht ?

[Sabotaz]

Hallo!

Dieser Code hat sich bewährt.

PHP-Code:

Function RangeToHTML(rng As Range)
    Dim Fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangeToHTML = ts.readall
    ts.Close
    RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set Fso = Nothing
    Set TempWB = Nothing
End Function


Gruß, René

Danke @mumpel für den Vorschlag. So richtig weiß ich aber nicht, was ich damit anfangen soll... ? Wenn ich das jetzt richtig verstehe, ist das nur ein Teil des eigentlichen Codes, der festlegt, was mit dem kopierten Range passieren soll? Wie muss ich das in den vorhandenen Code einfügen?

[volti]

Hallo Sabotanz,

hier mal ein einfaches Beispiel über die Wordeditorkopierung.
Mit Beispiel einer Textformatierung und Anhang der Signatur. Kann man ja auch wieder rausnehmen.

Den Einbau von RangeToHTML für das andere Beispiel kann Mumpel Dir ja erklären.

Code:

Private Sub Mail_BereichalsBereich_Word1()
' Sendet Mail mit integriertem Bereich als Bereich mit Signatur
  Dim WSh1 As Worksheet, WSh2 As Worksheet
  Dim sMailtext As String, iPers As Long
  
  iPers = 2                                           ' Nummer der Empfängerperson
  Set WSh1 = ThisWorkbook.Sheets("Daten")             ' Blatt mit Maildaten
  Set WSh2 = ThisWorkbook.Sheets("Tabelle1")          ' Datenblatt
  
  With CreateObject("Outlook.Application").CreateItem(0)
      iPers = (iPers * 3) - 2
      .Subject = WSh1.Range("B" & (iPers + 1)).Value  ' Betreff
      .To = WSh1.Range("B" & iPers).Value             ' Empfänger
      sMailtext = "Liste aktueller Aufträge:¶¶"
      .Getinspector.Display                           ' Signatur holen
      .htmlbody = "<span style='font-family:Arial;font-size:11pt;color:#000080;'><u>" _
                & Replace(sMailtext, "¶", "<br>") _
                & "</u></span>" & .htmlbody
      
      WSh2.Range("A1:F20").Copy                       ' Bereich kopieren
      With .Getinspector.WordEditor.Application.Selection
          .Start = Len(sMailtext) + 0                 ' Mit der Einfügestelle ggf. spielen + x
          .Paste                                      ' Bereich in Mail einfügen
      End With
      
  End With
End Sub

_________
viele Grüße
Karl-Heinz

[Sabotaz]

Super Sache! Danke vielmals! So sollte es aussehen, das gefällt mir schon sehr gut :)

Wie wird da auf die Mailadresse verwiesen? Das verstehe ich noch nicht ganz. "Nummer der Empfängerperson" verwirrt mich ein wenig... Sehr... Wenn ich iPers sehe, dann sehr...

[volti]

Hi,

ich ging davon aus, dass Du im Abstand von drei Zeilen deine Empfänger and Betreff stehen hast.

Anhand der iPers wird nun die jeweilige Zeile ermittelt, so dass Du über die Nummer beliebig viele Personen anschreiben könntest.

Geht natürlich auch anders.....

Gruß KH