Warum die Datei nicht in einem Schritt speichern und versenden? Code musst du auf deine Bedürfnisse anpassen!
Hier:
Sub Datei_als_XLSX_danach_versenden()
'Excel Instanzen
Dim Ordnerpfad As Variant
Dim filepath As String, Pfad As String, Dateiname As String, AktiveMappe As Workbook
Dim closefile As String, closefilename As String
'----------------------------------------------------------------------
'Outlook Instanzen
Dim OutApp As Object
Dim Textkopf As Object
Dim Text As String, Anrede As String, Grusswort As String
Dim Strbody As String, Gesamtertext As String
Dim Mailadresse As String, Betreff As String
Dim Anhang As String
'----------------------------------------------------------------------
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set AktiveMappe = ActiveWorkbook
'----------------------------------------------------------------------
filepath = AktiveMappe.FullName
Pfad = AktiveMappe.Path
Datum = Format(Now, "_dd.mm.yyyy_hh_mm_ss")
Dateiname = AktiveMappe.Name
If InStr(Dateiname, ".") > 0 Then
Dateiname = Left(Dateiname, InStr(Dateiname, ".") - 1)
End If
closefile = Pfad & "\" & Dateiname & Datum & "_Backup.xlsx"
closefilename = Dateiname & Datum & "_Backup.xlsx"
AktiveMappe.Save
AktiveMappe.SaveAs Filename:=closefile, FileFormat:=51
'Ordnerpfad = Shell("Explorer.exe " & Pfad, vbNormalFocus)
Application.Workbooks.Open (filepath)
Workbooks(closefilename).Close SaveChanges:=False
'----------------------------------------------------------------------
Anhang = closefile
'----------------------------------------------------------------------
'Mail vorbreiten
Mailadresse = "Beispiel@Beispiel.de" '->anpassen
Betreff = Dateiname & Datum & "_Backup"
Anrede = "Guten Tag<br><br>"
Text = "Exceldatei "
Grusswort = "Gruss"
Gesamtertext = Anrede & Text & " " & Dateiname & "<br><br>" & Grusswort
Set Textkopf = OutApp.CreateItem(olMailItem)
With Textkopf
.Recipients.Add Mailadresse
.Subject = Betreff
.HTMLBody = Gesamtertext
.Attachments.Add Anhang
.Display
' .Send
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
|