EXCEL VBA Mail mit unterschiedlichen Anhängen versenden

Servus,

ich habe folgende Frage - ich würde gerne PDFs aus einem Ordner an immer die gleiche Mail senden in einzelnen Mails. Hierzu hätte ich folgenden Ansatz:

Private Sub CommandButton3_Click()
Dim wks As Worksheet
Dim i As Integer
Dim letzteZeile As Integer
Dim dateiName As String
Dim dateiPfad As String

Dim olApp     As Object
Dim AWS       As String
Dim olOldbody As String


Set wks = Worksheets("Tabelle1") ' Name des Tabellenblattes anpassen  
Set olApp = CreateObject("Outlook.Application")  

letzteZeile = wks.Cells(Rows.Count, 1).End(xlUp).Row
dateiPfad = "I:Test"           ' Pfad anpassen  

For i = 1 To letzteZeile

    dateiName = wks.Range("A" & i).Value & ".pdf"  

    With olApp.CreateItem(0)
              .GetInspector.display
              olOldbody = .htmlBody
              .To = "test@email.at"   'E-Mail-Adresse anpassen.  
              .Subject = dateiName
              .htmlBody = "Hier kann Text rein oder nicht" & olOldbody ' "& olOldbody" ermöglicht die Verwendung einer Signatur  
              .Attachments.Add dateiPfad & dateiName
              '.send ' E-Mail wird gesendet wenn ' entfernt wurde  
    End With
    
Next i

End Sub

Nun aber die eigentliche Frage:

In dem Ordner befinden sich Rechnungen mit fortlaufender Nummer (20230001.pdf, 20230002.pdf, usw.) und es kommt auch des Öfteren vor, dass ein Beiblatt in der jeweiligen Rechnungsmail mit dem Namen 20230001a.pdf und 20230001b.pdf in der Mail mit der Rechnung 20230001 mit gesendet werden soll.

Ist das mittels VBA irgendwie realisierbar? Also, es sollte falls das Beiblatt mit dem Zusatz "a" oder "b" im Namen im Ordner ist, dieses mitgesendet werden, und falls nicht dann nur die jeweilige Rechnung.

Vielen Dank im Voraus für eure Hilfe!

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 42361648766

Url: https://administrator.de/contentid/42361648766

Ausgedruckt am: 23.11.2024 um 22:11 Uhr

4 Kommentare

Neuester Kommentar

Guten Morgen,
wenn der Dateiname immer eine Zahl ist, wäre folgendes Möglich:
- Teste ob der Dateiname eine Zahl ist (damit fallen die "Zusätze" raus, da die ja einen Buchstaben beinhalten)
- Suche ob es eine weitere Dateien zu dieser Nummer gibt, die einen Buchstaben im Dateinamen haben.
MFG
SH

Moin,

suche einfach alle Dateien in dem Verzeichnis, die das gewünschte "Pattern" haben:

Sub GetAllFileNames()
  Dim Files As String
  Files = Dir("I:\Test\" & wks.Range("A" & i).Value & "*.pdf")  
  
  Do While Files<> ""  
      Debug.Print Files
      Files = Dir()
  Loop
End Sub

In Anlehnung an: https://trumpexcel.com/vba-dir-function/

Und für jeden gefundenen Eintrag machst du einfach ein .Attachments.Add
Quelle: https://stackoverflow.com/questions/29154982/adding-multiple-attachments ...

Hallo,

vielen lieben Dank für eure Ansätze.

Leider bekomme ich es irgendwie nicht in meinen obigen Code verpackt sodass dieser auch läuft.

Vielleicht nochmal zur Erklärung. Die Ordnerstruktur sieht so aus:

Habs hinbekommen

Private Sub CommandButton1_Click()
    Dim wks As Worksheet
    Dim i As Integer
    Dim letzteZeile As Integer
    Dim dateiName As String
    Dim dateiPfad As String
    Dim olApp As Object
    Dim olOldbody As String
    Dim Files As String
    Dim fileGroups As Collection
    Dim fileGroup As Variant
    Dim fileAttachment As Variant

    Set wks = Worksheets("Tabelle1")  
    Set olApp = CreateObject("Outlook.Application")  

    letzteZeile = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    dateiPfad = "C:\Users\daniel\Documents\test\"  

    ' Initialize a collection to store file groups  
    Set fileGroups = New Collection

    ' Loop through the rows to group files  
    For i = 1 To letzteZeile
        dateiName = wks.Range("A" & i).Value  

        ' Search for files that match the pattern: [dateiName][any character].pdf  
        Files = Dir(dateiPfad & dateiName & "?*.pdf")  

        Dim fileArray() As String
        Dim fileCount As Integer
        fileCount = 0

        Do While Files <> ""  
            ReDim Preserve fileArray(0 To fileCount)
            fileArray(fileCount) = Files
            fileCount = fileCount + 1
            Files = Dir
        Loop

        If fileCount > 0 Then
            fileGroups.Add Array(dateiName, fileArray)
        End If
    Next i

    ' Loop through the file groups and create emails  
    For Each fileGroup In fileGroups
        With olApp.CreateItem(0)
            .GetInspector.Display
            olOldbody = .htmlBody
            .To = "test@email.at"  
            .Subject = fileGroup(0) & ".pdf"  
            .htmlBody = "Hier kann Text rein oder nicht" & olOldbody  
            For Each fileAttachment In fileGroup(1)
                .Attachments.Add dateiPfad & fileAttachment
            Next fileAttachment
            .Display
        End With
    Next fileGroup
End Sub