Alle Excel-Dateinen aus einem Ordner als E-Mail-Anhang

[FrankyHB]

Hallo liebe Excel-Gemeinde,

ich habe ein kleines Problem,

ich möchte per VBA alle Excel-Dateien aus einem Ordner als E-Mail Anhäge verschicken.

Bis jetzt habe ich folgenden Code:

Sub Datenübermittlung()

Dim Outlook As Object
Dim Mail As Object
Dim Att As Object
Dim strDateiname As String
Dim Pfad As String

Dim Laufwerk As String

Laufwerk = (Tabelle1.Range("A2").Value)

Pfad = (Laufwerk) & "" & "\DE\Bremen\Garden\Front Office\Module\Personal\*.xlsx"

Set Outlook = GetObject(, "outlook.application")
Set Mail = Outlook.CreateItem(0)

Mail.To = "tom@mustermann.de"
Mail.Subject = "Datenübermittlung vom " & " " & Format(Now, "DD.MM.YYYY")

Mail.Attachments.Add (Pfad)

Mail.Body = ("Sehr geehrte Damen und Herren,")

Mail.Display  ' Mail wird angezeigt, nicht direkt versandt.

End Sub


Das ganze klappt, wenn ich eine konkrete Datei auswähle, aber wenn ich mit * auswähle kommt die Meldung Datei nicht gefunden.

Wie kann ich das Problem lösen?

Lieben Gruß Frank

[00202]

Hallo,  

z. B. so:  

Code:

Option Explicit
Public Sub Main()
    Dim objOutApp As Object
    Dim strOrdner As String
    Dim strDatei As String
    Set objOutApp = CreateObject("Outlook.Application").CreateItem(0)
    strOrdner = "C:\Temp\Closed\"
    If Right$(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
    With objOutApp
        .To = "max@mustermann.de"
        .Subject = "Datenübermittlung vom " & " " & Format(Now, "DD.MM.YYYY")
        .Body = "Sehr geehrte Damen und Herren," & vbCr & vbCr & _
            "Sehr wichtiger Text." & vbCr & _
            "Der ist NOCH wichtiger!" & vbCr & _
            "Jetzt wird es peinlich." & vbCr & _
            "DAS GLAUBT KEINER!!!" & vbCr
        strDatei = Dir$(strOrdner & "*.xls*")
        Do Until strDatei = vbNullString
            .Attachments.Add strOrdner & strDatei
            strDatei = Dir$
        Loop
        .Display
    End With
    Set objOutApp = Nothing
End Sub

[FrankyHB]

Vielen Dank,

ich habe das ganze jetzt wie folgt gelöst:

Sub Datenübermittlung()

Dim Outlook As Object
Dim Mail As Object
Dim Att As Object
Dim strDateiname As String
Dim strPath As String
Dim strPDF As String
Dim strFile As String


Dim Laufwerk As String

On Error GoTo FehlerVerarbeitung

Laufwerk = (Tabelle1.Range("A2").Value)

strPath = (Laufwerk) & "" & "\DE\Bremen\Garden\Front Office\Module\Personal\"
strFile = Dir(strPath & "Stundenzettel*.xlsx")

Set Outlook = GetObject(, "outlook.application")
Set Mail = Outlook.CreateItem(0)

Mail.To = "max@mustermann.de"
Mail.Subject = "Datenübermittlung vom " & " " & Format(Now, "DD.MM.YYYY")

Do While Len(strFile) > 0
Mail.Attachments.Add strPath & strFile
strFile = Dir
Loop

Mail.Body = ("Hallo Max,") & Chr(10) & "" & Chr(10) & ("anbei die Backup-Sicherungen vom") & " " & Format(Now, "DD.MM.YYYY.") _

& Chr(10) & "" & Chr(10) & (Tabelle1.Range("F19").Value) & Chr(10) & "" & Chr(10) & (Tabelle1.Range("F4").Value)

Mail.Display  ' Mail wird angezeigt, nicht direkt versandt.

End Sub