2 Tabellen-blätter aus einem Excel per Mail versenden
15.03.2024 16:51:33
Daniela
Ich hatte vor zwei Jahren die Anfrage ob man aus einer Excel Arbeitsmappe mit zwei Tabellen-blätter zwei unterschiedliche PDF ins Outlook ladet.
Nun möchte ich euch fragen ob es auch mit dem gleichen Makro möglich ist, anstelle von PDF, zwei .xlsx Files in Outlook zu laden?
Sub PDF_MailVB()
Dim rng As Excel.Range
Dim strMail As String
With Worksheets("Bestaetigung").Columns("B")
Set rng = .Find("x", , xlValues, xlWhole, xlByColumns, MatchCase:=False)
If Not rng Is Nothing Then
strMail = rng.Offset(0, 1).Value
Dim Name As String
Dim Datei As String
' 1. PDF speichern mit individuellem Namen (Name + Datum)
Datei = "Bestätigung _" & Mid(Date, 1, 2) & Mid(Date, 4, 2) & Mid(Date, 9, 2) & _
"_" & Mid(Time, 1, 2) & Mid(Time, 4, 2) & Mid(Time, 7, 2) & ".pdf"
Name1 = ActiveWorkbook.Path + "\" + Datei
' 2. PDF speichern mit individuellem Namen (Name + Datum) !!!anpassen!!!!
Datei = "Zusatzinfo _" & Mid(Date, 1, 2) & Mid(Date, 4, 2) & Mid(Date, 9, 2) & _
"_" & Mid(Time, 1, 2) & Mid(Time, 4, 2) & Mid(Time, 7, 2) & ".pdf"
Name2 = ActiveWorkbook.Path + "\" + Datei
' anpassen!!!
Worksheets("Bestaetigung").ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name1, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' anpassen!!!
Worksheets("Zusatzinfo").ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name2, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' Diese Datei als Mail senden per Outlook
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
'Empfänger
Dim Empfänger As String, Betreff As String
Dim OutApp As Object, Mail As Object, i
Dim ClpObj As DataObject
Dim Nachricht
Empfänger = strMail
Betreff = "Info"
Set ClpObj = New DataObject
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Empfänger
.Subject = Betreff
'Betreff
.Subject = "Bestätigung" & Date & " um " & Time
'Nachricht
.Body = "text," & vbCrLf & _
"vielen Dank
.." & vbCrLf & _
"Mit freundlichen Grüssen" & vbCrLf & vbCrLf & _
"Sinceramente vostri"
'Lesebestätigung aus
.ReadReceiptRequested = False
'Dateianhang
.Attachments.Add Name1
.Attachments.Add Name2
.Display
End With
Set OutApp = Nothing
Set Nachricht = Nothing
End With
End If
End With
End SubFür eure Hinweise wäre ich sehr dankbar. Ich bin heute schon den ganzen Tag beim tüfteln. Leider erfolglos.