VBA - Mail generieren

[SteBen]

Hallo zusammen,

und hier kommt auch schon meine nächste Frage :D

Anbei findet Ihr meine Beispieldatei.

Ich möchte, dass bei Klick auf den Button eine Mail generiert (nicht geschickt) wird, die folgende Kriterien erfüllt.

> nur fällige Rechnungen, also YES in Spalte M, sollen in die Mail aufgenommen werden+
> die Mail soll dann wie folgt aufgebaut sein:

"Sehr geehrte Damen & Herren,

...

invoice number (hier sollen aber nur die Rechnungen gelistet sein, die in Spalte N den gleichen Empfänger haben!) + invoice amount + customer reference"

> Betreff der Mail soll alle Rechnungsnummern enthalten, die im Textkörper genannt sind + das aktuelle Datum
> Empfänger der Mail soll aus Spalte N übernommen werden + CC muss noch defniert werden

Kann mir jemand sagen, wie hierfür der VBA code aussehen muss?

Vielen Dank vorab 

Viele Grüße
SteBen

[Mase]

Das gibt es doch zuhauf im Netz zu finden.

lmgtfy

[SteBen]

Guten Morgen,

ich habe mir jetzt folgenden Code gebastelt.

Code:

Sub Schaltfläche1_Klicken()
On Error GoTo ErrHandler
   
   ' SET Outlook APPLICATION OBJECT.
   Dim objOutlook As Object
   Set objOutlook = CreateObject("Outlook.Application")
   
   ' CREATE EMAIL OBJECT.
   Dim objEmail As Object
   Set objEmail = objOutlook.CreateItem(olMailItem)

   With objEmail
       .To = Range("$N:$N")
       .CC = ""
       .Subject = "Unpaid invoices - XX" & " - " & Date
       .Body = "To whom this may concern." & Chr(13) & Chr(13) & "Dear business partner," & Chr(13) & Chr(13) & "please be informed that the attached invoices have not been paid until today. Pls check the cases and advise until when these invoices will be paid!" & Chr(13) & "Thank you! & Best Regards"
       .Display
       .Attachments.Add ("D:\XX\Desktop\XX - OP_template.xlsm")
       '.Send
       
   End With
   
   ' CLEAR.
   Set objEmail = Nothing:    Set objOutlook = Nothing
   
ErrHandler:

End Sub

Problem, sobald ich bei .To keine Mailadresse eintrage, läuft es nicht mehr. 

Wie muss ich den Code ändern, damit der Empfänger immer aus der ersten befüllten Zeile in Spalte N, einer gefilterten Excel Datei gezogen wird?
Und wie bekomme ich die Email Signatur des jeweilgen Absenders in die Mail?

Danke Euch

[SteBen]

noch ein Frage: 

Ich will die Datei der Mail anhängen, das ist auch kein Problem, krieg ich hin. Nur ist die Datei 26MB groß & ich würde gerne vorm versenden eine Kopie speichern, die nur die aktuellen Daten gem. gesetzten Filtern enthält..

habe den Code mal aus einem anderen Projekt kopiert. Das speichern klappt ohne Probleme, nur wie muss der Code aussehen, damit eine .xlsx Datei gespeichert wird, die nur die gefilterten Daten enthält? Bekomme derzeit immer ein PDF...

Code:

'Selektion als xlsx exportieren, um attachement Größe klein zu halten
ThisWorkbook.Sheets("template").ExportAsFixedFormat Type=xlTypeXLSX, Filename:= _
 "P:\XXX", Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Vielen Dank für Euren Rat

[Mase]

Moin,

Wie muss ich den Code ändern, damit der Empfänger immer aus der ersten befüllten Zeile in Spalte N, einer gefilterten Excel Datei gezogen wird?

Indem Du das .Offset(1,0) von .Range("N1") in Verbindung der Methode .SpecialCells(xlCellTypeVisible) verwendest.

---

nur wie muss der Code aussehen, damit eine .xlsx Datei gespeichert wird, die nur die gefilterten Daten enthält? Bekomme derzeit immer ein PDF...

Erstelle ein Worksheet in einem neuen Workbkook und kopiere das Filtrat da rein oder beschäftige Dich einfach mit .SaveAs2.

Alternative könntest das Filtrat auch direkt in die Mail schreiben. Schau dir hierzu die Methode .RangeToHtml an.

Somit hast keine zweite Datei, aber eine Kopie der Mail im Ordner gesendete Objekte.

[SteBen]

Hi Marco,

danke für die Hilfe.
Die Sache mit dem Mailempfänger habe ich hinbekommen - Danke schonmal!

Ich hänge gerade beim .RangetoHTML

Wie muss ich die Range im .HTMLBody anpassen, so dass nur alle Zeilen eingefügt werden, bei denen ein Wert in Spalte A steht?

Mein Code lautet so weit wie folgt: (hier wird nur der Wert aus A1 in die Mail kopiert... -.-

Code:

Sub Schaltfläche1_Klicken()

On Error GoTo ErrHandler
   
   ' SET Outlook APPLICATION OBJECT.
   Dim objOutlook As Object
   Set objOutlook = CreateObject("Outlook.Application")
   
   ' CREATE EMAIL OBJECT.
   Debug.Print RangetoHTML(Range("A1").Offset(1, 0))
   
   Dim objEmail As Object
   Set objEmail = objOutlook.CreateItem(olMailItem)

   With objEmail
       .To = Range("N1").Offset(1, 0)
       .CC = ""
       .Subject = "Unpaid invoices - XXX" & " - " & Date
       .HTMLBody = "Dear business partner," & Chr(13) & Chr(13) & "please be informed that the below mentioned invoices have not been paid until today. Pls check the cases and advise until when the payment will be settled!" & Chr(13) & "Thank you! & Best Regards" & Chr(13) & "" & Chr(13) & Chr(13) & RangetoHTML(Range("A1").Offset(1, 0))
       .Display
   End With
   
   ' CLEAR.
   Set objEmail = Nothing:    Set objOutlook = Nothing
   
ErrHandler:

End Sub

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"

   ' Copy the range and create a workbook to receive the data.
   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 Resume Next
       .DrawingObjects.Visible = True
       .DrawingObjects.Delete
       On Error GoTo 0
   End With

   ' Publish the sheet to an .htm file.
   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

   ' Read all data from the .htm file into the RangetoHTML subroutine.
   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=")

   ' Close TempWB.
   TempWB.Close savechanges:=False

   ' Delete the htm file.
   Kill TempFile

   Set ts = Nothing
   Set fso = Nothing
   Set TempWB = Nothing
End Function

Und noch eine Sache, wie bekomme ich die Mailsignatur des Kollegen in die Mail der das Makro auslöst?

Vielen Danke für die Hilfe!!

---

Eine Sache ist mir gerade noch aufgefallen.

Wenn ich das so schreibe

Code:

.To = Range("N1").Offset(1, 0)

dann nimmt er immer die Mailadresse, die in N2 steht, aber es sind ja unterschiedliche, je nachdem welcher Kunde es ist. Er muss sich also immer die 1. Zelle unter der Überschift der Spalte N als Empfänger ziehen.... 

Nue wie geht das?? 

[SteBen]

Hab's auch noch so versucht, aber so tut sich leider nichts...

Code:

' CREATE EMAIL OBJECT.
   Debug.Print RangetoHTML(Range("A1", Range("A1").End(xlDown) & (Range("A1", Range("A1").End(xlToRight).Offset(1, 0)))))

[Mase]

Erstelle ein Worksheet in einem neuen Workbkook und kopiere das Filtrat da rein oder beschäftige Dich einfach mit .SaveAs2.

Anbei ein Code wo dir dir gefilterten Daten in Array schreibt, diese dann entsprechend im zu exportierenden Worksheet schreiben lassen.
(a bissl Lust an Leistung vorausgesetzt)

Code:

Sub FilteredRangeToArray()
    Dim sArr() As String
    Dim rngFiltrat As Range
    Dim arrRng() As Range
    Dim arrV() As Variant
    Dim i As Long
    Dim wks As Worksheet
    '
    Set wks = ThisWorkbook.Worksheets(1)
    '
    With Tabelle1
        '
        If Not .AutoFilterMode = True Then Exit Sub
        '
        Set rngFiltrat = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
        Let sArr = Split(rngFiltrat.AddressLocal, ";")
        
        ReDim arrRng(UBound(sArr))
        ReDim arrV(UBound(sArr))
        For i = 0 To UBound(sArr) Step 1
            Set arrRng(i) = Tabelle1.Range(sArr(i))
            Let arrV(i) = arrRng(i)
        Next i
    End With
    '
    Erase sArr()
    Erase rngFiltrat()
    Erase arrRng()
    Erase arrV()
End Sub

---

' CREATE EMAIL OBJECT.

   Debug.Print RangetoHTML(Range("A1", Range("A1").End(xlDown) & (Range("A1", Range("A1").End(xlToRight).Offset(1, 0)))))

Bspw so:

Code:

.Body = "Sehr geehrte ...." & RangeToHtml(Range("A1:A10"))

[SteBen]

Hallo Marco,

danke für Deine Antwort, nur leider komme ich damit nicht weiter. 
Bin VBA-Neuling & stückel mir die Sachen, die ich brauche son bisschen mit copy paste zurecht.

Deswegen wäre es super, wenn Du mir das ganze ein bisschen ausführlicher erklären könntest 



Besten Dank vorab

[SteBen]

Hallo Marco, Forum,

noch eine Idee dazu? :)