vba datei separat per mail senden
23.02.2023 12:54:52
Giuppy
ich habe in einen Ordner mehrere pdf Dateien und möchte jede Datei mit VBA separat per mail versenden und als Betreff der Dateinname (oder nur die ersten 8 ziffern)
z.B. Ordner xy hat 15 Files dann werden 15 mail versendet und als Betreff der Filename oder die ersten 8 ziffern der Datei
OrdnerName = xxx_PDF
Filename 1020 an mail xxx@xxx.de Betreff = 1020
Filename 1050 an mail xxx@xxx.de Betreff = 1050
usw.
OrdnerName = ZZZ_PDF
Filename 2000 und Filename 3000 und Filename 5000 an mail zzz@zzz.de als Betreff zzz_ & Zeitraum
Bis jetzt habe ich alle Dateien in der Mail angehägt siehe VBA
was muss ich ändern nur für ein besteimmte mail adresse die Dateien einzeln zu verschicken?
Viele Grüße
Giuppy
Sub a4_MAIL_Schleife()
Application.ScreenUpdating = False
Dim Z As Range 'Z wie Zelle
Sheets("Kontrolle").Select
If Range("E1") > "OK" Then ' Kontrolle
MsgBox "Bitte RECHNUNGEN KONTROLLIEREN."
ElseIf Range("C1") = 0 Then ' Kontrolle
MsgBox "KEINE RECHNUNGEN."
Else
For Each Z In Range(Range("B2"), Cells(Rows.Count, 2).End(xlUp))
If Z.Value > 0 Then MailenNachZeilen Z.Row, Range("H6").Value
Next
End If
Range("H11").Select
End Sub
Sub MailenNachZeilen(ZeileNr As Long, Zeitraum As String)
Application.ScreenUpdating = False
Dim OutApp As Outlook.Application
Dim OutEmail As Outlook.MailItem
'Eine neue Instanz von Outlook erzeugen
Set OutApp = New Outlook.Application
Set OutEmail = OutApp.CreateItem(olMailItem)
Dim Mailtext As String
Dim strPath As String
Dim strFile As String
Dim empfänger As String
Dim Betreff As String
'Zeitraum = Range("H6")
empfänger = Worksheets("Stammdaten").Range("I" & ZeileNr).Value
Betreff = Range("A" & ZeileNr).Value & "_" & Zeitraum
strPath = "C:\#KDFatture\MAIL_NEW\PDF\" & Range("A" & ZeileNr).Value & "_PDF\"
Mailtext = "
" _
& "Sehr geehrte Damen und Herren ," & "
" _
& "anbei sende ich Ihnen die Rechnungen für den Zeitraum " & Zeitraum & "
" _
& "Gerne stehen wir Ihnen für evtl. weitere Rückfragen zur Verfügung." & "
" _
& "Mit freundlichen Grüßen" & "
" _
& "Innendienst" & "
" _
& "XXX GmbH" & "
" _
& " Straße" & "
" _
& "PLZ Stadt" & "
" _
& "Tel. xxx/xxxx" & "
" _
& "Fax xxx/xxxxxx" & "
" _
& "Mail: " & "Innendienst@xxx.de" & "
With OutEmail
.GetInspector.Display
.To = empfänger
'.CC = ""
OutEmail.Subject = Betreff
.HTMLBody = Mailtext
'.attachments.Add Anhang
strFile = Dir(strPath & "*.*")
Do While Len(strFile) > 0
.attachments.Add strPath & strFile
strFile = Dir
Loop
'.Display
.Send
End With
Set OutlookApplication = Nothing
Set Nachricht = Nothing
End Sub