AW: Outlook via Excel mit Anforderungen
17.02.2016 14:22:30
Marcus
'Button erstellen und dieses
Sub dazu verknüpfen -
'läuft bei mir schon ne weile problemlos, allerdings wird auf dem
'Netzlaufwerk X: unter einem bestimmten Pfad die versandte Datei als xls mit abgelegt und _
gespeichert.
Sub Excel_Sheet_via_Outlook_Senden_Click()
'E-Mail-Fenster generieren:
Dim Nachricht As Object, OutApp As Object
'Speicherort für Kopie des Tabellenblattes festlegen und als Wert übernehmen:
Dim SavePath As String
'aktuellen Tabellenblattnamen als Speichername übernehmen:
Dim AWS As String
'Speicherort für die Datei definieren:
SavePath = "X:\Dein speicherpfad hier anpassen"
'Blattschutz aufheben für Aktion
ActiveSheet.Unprotect Password:="1234"
'Kopiert aktuelles Sheet in eine neue Mappe, welche nur diese Tabelle enthält
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'kopiert nur die Werte ohne Verknüpfungen zum Original
Dim vlink As Variant
ActiveSheet.Copy
vlink = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(vlink) Then
For J = 1 To UBound(vlink)
ActiveWorkbook.BreakLink vlink(J), Type:=xlLinkTypeExcelLinks
Next J
End If
'entfernt die Buttons, die auf dem Originalsheet das Script auslösen
ActiveSheet.Shapes.SelectAll
Selection.Delete
Dim lngLastRow As Long, lngLastColumn As Long
With ActiveSheet
lngLastRow = .Cells.Find(what:="*", After:=Range("A1"), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lngLastColumn = .Cells.Find(what:="*", After:=Range("A1"), _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
.PageSetup.PrintArea = "$A$1:" & .Cells(lngLastRow, lngLastColumn).Address
End With
'entfernt Makros
Dim Ding As Object 'Makros werden gelöscht
Dim Zeile As Long
Dim Antwort As Integer
For Each Ding In ActiveWorkbook.VBProject.VBComponents
If Ding.Type = 100 Then
With ActiveWorkbook.VBProject.VBComponents(Ding.Name).CodeModule
For Zeile = 1 To .CountOfLines
.DeleteLines 1
Next Zeile
End With
Else
ActiveWorkbook.VBProject.VBComponents.Remove Ding
End If
Next
Application.DisplayAlerts = False
'Speichert die Datei unter dem Tabellennamen und dem Datums-Zeitstempel
ActiveWorkbook.SaveAs SavePath & "\" & Format(Date, "yyyymmdd") & "_" & ActiveSheet. _
Name & ".xls" _
, FileFormat:=xlNormal, CreateBackup:=False
'Mappenname wird an Variable übergeben und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
.Close
End With
'InitializeOutlook = True
ActiveSheet.PageSetup.PrintArea = False
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
'Empfänger/Verteilerliste definieren, an die die E-Mail gesendet wird
.To = "empfaenger1@mail.de; empfaenger2@mail.de"
'Betreff mit Bezeichnung des Sheets erstellen:
.Subject = ActiveSheet.Name & " vom " & Date
.Attachments.Add AWS
'Generierung des PDF parallel:
Dim IsCreated As Boolean
Dim i As Long
Dim char As Variant
Dim PdfFile As String, Title As String
PdfFile = Format(Date, "yyyymmdd") & "_" & ActiveSheet.Name
i = InStrRev(PdfFile, ".xl", , vbTextCompare)
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile '& "_" & ActiveSheet.Name
For Each char In Split("? "" / \ * | :")
PdfFile = Replace(PdfFile, char, "_")
Next
PdfFile = Left(ActiveWorkbook.Path & "\" & PdfFile, 251) & ".pdf"
' Export activesheet as PDF im Speicherpfad
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
'hinzufügen des PDF-Dokuments zur E-Mail
.Attachments.Add PdfFile
'Hier wird die HTML Mail erstellt mit dem anzupassenden Text:
.Body = "Text der Email im Body hier." 'anpassen
'Hier wird die Mail nochmals angezeigt
.Display
End With
Set MyOutApp = Nothing
Set MyMessage = Nothing
Application.ScreenUpdating = True
'Schreibschutz für Tabellenblatt aktivieren mit deinem Passwort
ActiveSheet.Protect Password:="1234" '1234 ist als Passwort gesetzt
End Sub
Hoffe das hilft Dir weiter.
Kopie der PDF nicht zu Speichern habe ich selbst auch noch nicht hinbekommen.
Anhang wird nur aus dem dargestellten Blatt mit dem Stand JETZT erstellt.
Bin auch kein VBA Profi, habe aber mit viel Geduld das Script zum Laufen gebracht.
LG
Marcus