AW: Outlook Daten anhängen VBA
07.06.2019 07:51:21
Marco
Hallo Giorgi,
vielleicht hilft Dir das Makro von mir weiter. Da es ein Teil eines größeren Makros ist, kannst Du da sicher noch einiges rausschmeissen oder für Dich anpassen.
In meinem Makro wird wird eine Email mit der Tabelle als XLS und PDF versand.
Du kannst es ja einmal testen und schauen ob Du etwas gebrauchen kannst. :)
Du musst natürlich wieder den Verweis auf Outlook setzen. Die Unterbrechung erfolgt nur aus dem Editor.
Bei Fragen melde Dich einfach.
Viele Grüße
Marco
Option Explicit
Dim verzeichnis2 As String
Dim exportpdffile As String
Dim exportxlsfile As String
Dim ws2 As String
Dim mailto As String
Dim betreff As String
Dim customtext As String
Private Sub CommandButton1_Click()
ws2 = ActiveSheet.Name
On Error Resume Next
Dim email As Variant
email = ActiveSheet.Cells(2, 10)
Dim rng As Range
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Set rng = Nothing
On Error Resume Next 'Only the visible cells in the selection
Set rng = ActiveSheet.Range("a1:f500").SpecialCells(xlCellTypeVisible) 'Hier den Bereich _
der gesamten Tabelle angeben
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Die Auswahl ist kein Bereich oder das Tabellenblatt ist geschützt.", vbOKOnly
Exit Sub
End If
ws2 = InputBox("Bitte geben Sie den gewünschten Dateinamen ein:", "Dateiname eingeben", " _
TabelleFuerMail")
verzeichnis2 = Environ("TEMP") & "\"
exportpdffile = verzeichnis2 & ws2 & "_" & Format(Date, "DDMMYYYY") & ".pdf"
exportxlsfile = verzeichnis2 & ws2 & "_" & Format(Date, "DDMMYYYY") & ".xls"
' Export PDF
Application.DisplayAlerts = False
If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
MsgBox "Sie können leider keine leere Tabelle versenden!", vbInformation + vbOKOnly
Exit Sub
Else
ActiveSheet.ExportAsFixedFormat xlTypePDF, exportpdffile, Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=True, OpenAfterPublish:=False
End If
'Export XLS
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Sheets("Tabelle2").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Tabelle3").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayFormulaBar = False
Range("A1").Select
ActiveWorkbook.SaveAs Filename:=exportxlsfile, FileFormat:=xlExcel8, Password:="", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
If mailto = "" Then mailto = InputBox("Bitte geben Sie den Empfänger(Email) ein:", "Empfä _
nger eingeben", "email@desEmpfängers.com")
Dim olApp As Outlook.Application
Dim olNameSpace As Namespace
Dim objMailItem As MailItem
Dim objFolder As MAPIFolder
Set olApp = CreateObject("Outlook.Application")
Set olNameSpace = olApp.GetNamespace("MAPI")
Set objFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set objMailItem = objFolder.Items.Add(olMailItem)
If betreff = "" Then betreff = "Sie haben eine Excel-Tabelle erhalten"
If customtext = "" Then customtext = "Sehr geehrte Damen und Herren,
Sie haben _
folgende Tabelle als Anlage erhalten:"
With objMailItem
.To = mailto
.Subject = betreff
.HTMLBody = "" & customtext & "
"
On Error Resume Next
.Attachments.Add exportpdffile
.Attachments.Add exportxlsfile
.Display
End With
olApp.ActiveWindow
SendKeys "%s"
Kill exportpdffile
Kill exportxlsfile
Application.DisplayAlerts = True
Range("A1").Select
End Sub