Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1472to1476
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Outlook via Excel mit Anforderungen

Outlook via Excel mit Anforderungen
15.02.2016 11:16:51
Olli
Hallo Zusammen
Ich habe eine kleine Herausforderung mit dem Erstellen einer Outlookmail mit folgenden Anforderungen.
Anforderungen:
  • Kopie vom aktuellem sheet (Tabelle1) soll in Outlook als *.xls und *.pdf Datei mit angehängt werden

  • Von der PDF Datei sollte keine Kopie auf dem Laufwerk erstellt werden

  • Sheet sollte mit Passwort 1234 schreibgeschützt werden

  • Auf dem Laufwerk sind nur Leserechte vorhanden

  • Kompatibillitätsprüfung soll nicht durchgeführt werden

  • Der Anhang sollte den aktuellen Stand anhängen und kein unausgefülltes Sheet

  • Habe eine Datei mit meinem aktuellen Quellcode mit angehängt.
    https://www.herber.de/bbs/user/103547.xls
    Hatte einen Versuch mit der Methode ActiveWorkbook.SendMail durchgeführt nur ich möchte gerne ein CC Verteiler und von der Datei ein xls und pdf Anhang.
    Vielleicht hat einer von Euch eine Idee und kann mir helfen.

    2
    Beiträge zum Forumthread
    Beiträge zu diesem Forumthread

    Betreff
    Datum
    Anwender
    Anzeige
    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

    Anzeige
    AW: Outlook via Excel mit Anforderungen
    17.02.2016 17:25:10
    Olli
    Hallo Marcus
    Danke vorab
    Bekomme leider etliche Fehlermeldungen. Vielleicht kriege ich das noch hin, das kein PDF auf dem Laufwerk erstellt wird.

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige