Mehrere Dateien per VBA an E-Mail anhängen

[dachboden20]

Mahlzeit! Ich habe mir mit Hilfe von Google usw. folgenden Code zusammen gesucht und gebastelt:

Option Explicit
Public Sub TableToMail()
    Dim objOutlook As Object
    Dim objMail As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .To = "rr"
        .Subject = Range("B3").Value
        .htmlBody = RangeToHTML(ActiveSheet, ActiveSheet.Range("E:J"))
        .Attachments.Add (Range("D5").Value)
        .display    'nur Anzeigen
'        .Send       'direkt senden
         End With
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

Private Function RangeToHTML(objSheet As Worksheet, objRange As Range) As String
    Dim strFilename As String
    strFilename = Environ$("TEMP") & "/" & Format(Now, "dd-mm-yyyy_hh-mm-ss") & ".htm"
    ActiveWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        FileName:=strFilename, _
        Sheet:=objSheet.Name, _
        Source:=objRange.Address, _
        HtmlType:=xlHtmlStatic).Publish True
    RangeToHTML = CreateObject("Scripting.FileSystemObject"). _
        GetFile(strFilename).OpenAsTextStream(1, -2).ReadAll
    Kill strFilename
End Function

Dieser Code erstellt mir für einen ausgewählten Bereich eine E-Mail mit einem Anhang. In Spalte D ab Zeile 5 steht der Pfad der Datei, die angehangen werden soll. Nun ist es aber so, dass mir mit diesem Code nur der Anhang zum Pfad der Zelle D5 angehangen wird. In den folgenden Zeilen könnt aber auch ein Dateipfad zu finden sein. Wie kann ich der E-Mail mehrere Dateien anhängen. Wie gesagt, Pfad befindet sich immer im Spalte D. Die Anzahl der Dateien ist variabel.

 

[Bob1337]

Hallo,

probiere mal mit einer For-Schleife alle Objects die in dem Ordner sind als Anhang hinzuzufügen.

Hier kannst du nachlesen wie es geht.

https://www.slipstick.com/developer/code-samples/working-items-folder-selected-items/

Gruß
Bob

 

[Lavaground]

.Attachments.Add (Range("D5").Value)

ändern in

.Attachments.Add (Range("D5").End(xlDown).Value)

das müsste D5 bis D ENDE auswählen oder du nimmst

.Attachments.Add (Range("D5:D65536").Value)

Ob dies aber die Attachments einzeln hinzufügt oder versucht aus allem Eines zu machen kann ich dir nicht sagen, da klingt der For-Loop Vorschlag besser.

 

[Spike S.]

Durch Verwendung von ActiveSheet.Cells() statt Range(), lässt es sich leichter in einer Schleife abarbeiten...

    Dim dateiInZeile as Integer
    dateiInZeile = 5 'Startzeile vorgeben
    With objMail
        .To = "rr"
        .Subject = Range("B3").Value
        .htmlBody = RangeToHTML(ActiveSheet, ActiveSheet.Range("E:J"))
        While Dir(ActiveSheet.Cells(dateiInZeile, 4).Value) <> "" 'Solange hintereinander gültige und existierende Dateipfade angegeben sind, füge sie alle einzeln als Anhang hinzu
            .Attachments.Add (ActiveSheet.Cells(dateiInZeile, 4).Value) 'Spalte D hat die Nummer 4
            dateiInZeile = dateiInZeile + 1
        Wend
        .display    'nur Anzeigen
'        .Send       'direkt senden
    End With

Wobei es in dem Fall auch gehen würde, da sich die Spalte nicht ändert...

    Dim dateiInZeile as Integer
    dateiInZeile = 5 'Startzeile vorgeben
    With objMail
        .To = "rr"
        .Subject = Range("B3").Value
        .htmlBody = RangeToHTML(ActiveSheet, ActiveSheet.Range("E:J"))
        While Dir(Range("D" & dateiInZeile).Value) <> "" 'Solange hintereinander gültige und existierende Dateipfade angegeben sind, füge sie alle einzeln als Anhang hinzu
            .Attachments.Add (Range("D" & dateiInZeile).Value)
            dateiInZeile = dateiInZeile + 1
        Wend
        .display    'nur Anzeigen
'        .Send       'direkt senden
    End With

Diese Variante hört auf, sobald ein ungültiger Dateipfad angegeben ist. Wenn also beispielsweise untereinander 3 Dateien angegeben sind (D5 bis D7) und Datei in der Mitte (D6) nicht existiert, wird nur die Datei aus D5 angehangen. Oder wenn in D5 nichts steht, passiert gar nichts, keine Anhänge.

 

[dachboden20]

Vielen Dank für eure Kommentare und Ratschläge.

Hallo,

probiere mal mit einer For-Schleife alle Objects die in dem Ordner sind als Anhang hinzuzufügen.

Hier kannst du nachlesen wie es geht.

https://www.slipstick.com/developer/...elected-items/

Gruß
Bob

Mir fehlt es einfach nötiger Kenntnis, da richtig durchzublicken. Aber trotzdem Danke.

Lavaground

AW: Mehrere Dateien per VBA an E-Mail anhängen
Code:

.Attachments.Add (Range("D5").Value)

ändern in
Code:

.Attachments.Add (Range("D5").End(xlDown).Value)

das müsste D5 bis D ENDE auswählen oder du nimmst
Code:

.Attachments.Add (Range("D565536").Value)

Ob dies aber die Attachments einzeln hinzufügt oder versucht aus allem Eines zu machen kann ich dir nicht sagen, da klingt der For-Loop Vorschlag besser.

Der 1.Code spuckt mir leider nur 1 Datei aus. Der 2.Code funktioniert nicht, wird mir aber sicher auch nur 1 Datei anhängen, oder!? --> Laufzeitfehler 5: ungültiger Orozeduraufruf oder ungültiges Argument

Das für mich interessanteste ist der Vorschlag von Spike. Allerdings wird mir hier bei beiden Varianten ein Fehler angezeigt.
Zeile 7 -> Laufzeitfehler 13 "Typen unverträglich"
Gibt es da eine Lösung? Des weiteren wird es vorkommen, dass zwischendurch kein gültiger Pfad angegeben ist, da es da einfach keine Datei gibt. Hier soll Excel dann aber trotzdem noch die restlichen Zeilen durchsuchen.

 

[Bob1337]

Hallo,

so könnte die For-Schleife aussehen.

Dim objOL As Outlook.Application
    Dim objItems As Outlook.Items
    Dim objFolder As Outlook.MAPIFolder
    Dim obj As Object
 
    Set objOL = Outlook.Application

    Set objFolder = Ns.GetDefaultFolder(Range("D5").Value)
    Set objItems = objFolder.Items

'Hier beginnt die Schleife
 
    For Each obj In objItems
 
         attachments.add(obj.Name)

    Next

'Hier endet sie
 
    Set obj = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
    Set objOL = Nothing

 

[dachboden20]

Kannst du mir das in meinen Code einbauen? Ich ahbe den glaube gerade total zerschossen...

 

[Spike S.]

Ok, habe eben festgestellt, wenn der Inhalt eine Zeile leer ist, kommt dieser Laufzeitfehler. Denn dann wird mit Dir("") nach keiner Datei gesucht, was weniger sinnvoll ist. Muss also abgefangen werden.

Wenn es keine hintereinander stehende Liste von Dateipfaden ist, muss die Spalte mit einer For-Schleife bis zur letzten in der Tabelle verwendeten Zeile durchgegangen und geprüft werden.

        Dim dateiInZeile as Long
        With objMail
            .To = "rr"
            .Subject = Range("B3").Value
            .htmlBody = RangeToHTML(ActiveSheet, ActiveSheet.Range("E:J"))
            For dateiInZeile = 5 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row Step 1
                If ActiveSheet.Range("D" & dateiInZeile).Value <> "" Then
                    If Dir(ActiveSheet.Range("D" & dateiInZeile).Value) <> "" Then
                        If GetAttr(ActiveSheet.Range("D" & dateiInZeile).Value) <> vbDirectory Then
                            .Attachments.Add (Range("D" & dateiInZeile).Value)
                        End If
                    End If
                End If
            Next
            .display    'nur Anzeigen
    '        .Send       'direkt senden
        End With

Anmerkung: ich habe in diesem Fall auch noch den Datentyp von dateiInZeile von Integer auf Long geändert, da ich annehme es wird Office 2007 oder neuer verwendet. Hintergrund ist, Integer hat eine Obergrenze von 65535, ab Excel 2007 können Tabellen aber deutlich mehr als 1.000.000 Zeilen haben. Einfach nur zur Sicherheit...