AW: Danke...so funktioniert es. Dateien aufzählen?
16.05.2019 21:46:16
Nepumuk
Hallo Sabbel,
befinden wir uns auf der Zielgeraden? :-)
Option Explicit
Public Sub Mail_senden()
Const FOLDER_PATH As String = "H:\Bestellung\"
Dim objOutlook As Object, objMail As Object
Dim strFolder As String, strFileName As String, astrFiles() As String
Dim strAttachments As String, strOrder As String
Dim avntAttachments() As Variant
Dim ialngIndex As Long
Dim dtmDate As Date
dtmDate = Worksheets("Eingabe").Range("G3").Value
strOrder = "Bestellung vom " & Format$(dtmDate, "dd.mm") & ".pdf"
strFolder = FOLDER_PATH & Format$(dtmDate, "yyyy") & _
"\" & Format$(dtmDate, "mmmm") & "\"
strFileName = Dir$(strFolder & "*" & Format$(dtmDate, "mm-dd") & "*.pdf")
Do Until strFileName = vbNullString
Redim Preserve avntAttachments(ialngIndex)
Redim Preserve astrFiles(ialngIndex)
avntAttachments(ialngIndex) = Chr$(34) & strFolder & strFileName & Chr$(34)
astrFiles(ialngIndex) = strFileName
ialngIndex = ialngIndex + 1
strFileName = Dir$
Loop
If ialngIndex = 0 Then
Call MsgBox("Keine Dateien gefunden.", vbExclamation, "Hinweis")
Else
strAttachments = Join(avntAttachments, " ")
Call Shell(PathName:="C:\Program Files (x86)\PDFtk\bin\pdftk.exe " & _
strAttachments & " cat output " & Chr$(34) & FOLDER_PATH & _
strOrder & Chr$(34), WindowStyle:=vbHide) 'Pfad anpassen !!!
Call Application.Wait(Time:=Now + TimeSerial(0, 0, 3))
Set objOutlook = CreateObject(Class:="Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "name@provider.de"
.Subject = "Betreff"
.Body = "Hallo" & vbLf & vbLf & "im Anhang die Datei." & vbLf & vbLf & _
"Die Datei enthält:" & vbLf & Join(astrFiles, vbLf) & _
vbLf & vbLf & "Gruß" & vbLf & "Sabbel"
Call .Attachments.Add(FOLDER_PATH & strOrder)
Call .Display 'Anzeigen
' Call .Send 'direkt senden
End With
Set objMail = Nothing
Set objOutlook = Nothing
Call Kill(PathName:=FOLDER_PATH & strOrder)
End If
End Sub
Gruß
Nepumuk