Hallo zusammen,
ich wollte mit Outlook 2019 Exchange ein Makro schreiben, welches mir den E-Mail Text und die Anhänge als PDF ausdruckt bzw. abspeichert.
Mit diesem Code
Kann ich schon den E-Mail Text und die PDF Anhänge super erstellen.
Jetzt möchte ich diese PDF-Dateien der Reihe nach (00.., 01,, usw.) zu einer machen. (Deshalb auch die Nummerierung am Anfang der Dateien)
Der Code (Zeile 63 – 73) läuft ohne Fehlermeldungen und so durch. Aber leider gibt es keine PDF-Datei. OK, dachte ich. der Code stammte ja auch aus einem VB.NET Projekt. Also schnell ein neues Testprojekt erstellt.
Den Verweis auf die passende DLL noch schnell gesetzt und gestartet.
PDF wurde sauber und funktionsfähig erstellt. Also ist doch die DLL richtig installiert bzw. registriert und funktioniert.
(Die Pfade habe ich aus Outlook kopiert und hier nur eingefügt).
Jetzt halt meine Frage: Warum klappt das nicht mit Outlook? Oder gibt es da noch eine andere Möglichkeit?
Freundliche Grüße
Volker
P.S. In Anhang mal die DLL-Datei
ich wollte mit Outlook 2019 Exchange ein Makro schreiben, welches mir den E-Mail Text und die Anhänge als PDF ausdruckt bzw. abspeichert.
Mit diesem Code
VB.NET-Quellcode
- ' https://ekiwi-blog.de/6533/vba-e-mail-pdf-anhang-drucken/
- Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
- Public Const Verz As String = "C:\Temp\Outlook\"
- Public OutlookDateiname As String
- Public Sub PrintSelectedAttachments()
- On Error Resume Next
- MkDir Verz
- On Error GoTo 0
- ' Nachricht als PDF abspeichern
- OutlookDateiname = SaveMessageAsPDF
- ' Anhänge abspeichern
- Dim Exp As Outlook.Explorer
- Dim Sel As Outlook.Selection
- Dim obj As Object
- Set Exp = Application.ActiveExplorer
- Set Sel = Exp.Selection
- For Each obj In Sel
- If TypeOf obj Is Outlook.MailItem Then
- PrintAttachments obj
- End If
- Next
- ' Alle zusammenfügen
- Dim Dateien As String
- Dim DateiSplit() As String
- Dim Ziel As String
- Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
- Set mobjFSO = CreateObject("Scripting.FileSystemObject")
- Set mfsoFolder = mobjFSO.GetFolder(Verz)
- On Error Resume Next
- Dateien = ""
- For Each mfsoFile In mfsoFolder.Files
- If Not mfsoFile Is Nothing Then
- If InStr(1, mobjFSO.GetFileName(mfsoFile), ".pdf") > 0 Then
- Dateien = Dateien & mfsoFile & "|"
- End If
- End If
- Next
- Dateien = Mid(Dateien, 1, Len(Dateien) - 1)
- pdf = New PDFSplitMerge.CPDFSplitMergeObj
- DateiSplit = Split(Dateien, "|")
- Ziel = Replace(DateiSplit(0), "00_", "99_")
- MsgBox (Ziel & vbCrLf & Dateien)
- Call pdf.Merge(Dateien, Ziel)
- pdf = Nothing
- MsgBox ("Fertig")
- End Sub
- Private Sub PrintAttachments(oMail As Outlook.MailItem)
- On Error Resume Next
- Dim colAtts As Outlook.Attachments
- Dim oAtt As Outlook.Attachment
- Dim sFile As String
- Dim sFileType As String
- Dim AnzahlAnhänge As Integer
- AnzahlAnhänge = 1
- Set colAtts = oMail.Attachments
- If colAtts.Count Then
- For Each oAtt In colAtts
- sFileType = LCase$(Right$(oAtt.FileName, 4))
- Select Case sFileType
- Case ".pdf"
- sFile = Verz & Format(AnzahlAnhänge, "00_") & OutlookDateiname & " " & oAtt.FileName
- oAtt.SaveAsFile sFile
- 'ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
- AnzahlAnhänge = AnzahlAnhänge + 1
- End Select
- Next
- End If
- End Sub
- Public Function SaveMessageAsPDF() As String
- Dim Selection As Selection
- Dim obj As Object
- Dim Item As MailItem
- Dim wrdApp As Word.Application
- Dim wrdDoc As Word.Document
- Set wrdApp = CreateObject("Word.Application")
- Set Selection = Application.ActiveExplorer.Selection
- For Each obj In Selection
- Set Item = obj
- Dim FSO As Object, TmpFolder As Object
- Dim OutlookDateiname As String
- Set FSO = CreateObject("Scripting.FileSystemObject")
- Set tmpFileName = FSO.GetSpecialFolder(2)
- OutlookDateiname = Item.Subject & " " & Item.CreationTime
- ReplaceCharsForFileName OutlookDateiname, "-"
- tmpFileName = Verz & "00_" & OutlookDateiname & ".mht" 'tmpFileName & "\" & OutlookDateiname & ".mht"
- Item.SaveAs tmpFileName, olMHTML
- Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True)
- Dim WshShell As Object
- Dim SpecialPath As String
- Dim strToSaveAs As String
- Set WshShell = CreateObject("WScript.Shell")
- strToSaveAs = Verz & "00_" & OutlookDateiname & ".pdf"
- ' check for duplicate filenames
- ' if matched, add the current time to the file name
- If FSO.FileExists(strToSaveAs) Then
- OutlookDateiname = OutlookDateiname & Format(Now, "hhmmss")
- strToSaveAs = Verz & "00_" & OutlookDateiname & ".pdf"
- End If
- wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
- strToSaveAs, ExportFormat:=wdExportFormatPDF, _
- OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
- Range:=wdExportAllDocument, From:=0, To:=0, Item:= _
- wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
- CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
- BitmapMissingFonts:=True, UseISO19005_1:=False
- Next obj
- wrdDoc.Close
- wrdApp.Quit
- Set wrdDoc = Nothing
- Set wrdApp = Nothing
- Set WshShell = Nothing
- Set obj = Nothing
- Set Selection = Nothing
- Set Item = Nothing
- SaveMessageAsPDF = OutlookDateiname
- End Function
- ' This function removes invalid and other characters from file names
- Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
- sName = Replace(sName, "/", sChr)
- sName = Replace(sName, "\", sChr)
- sName = Replace(sName, ":", sChr)
- sName = Replace(sName, "?", sChr)
- sName = Replace(sName, Chr(34), sChr)
- sName = Replace(sName, "<", sChr)
- sName = Replace(sName, ">", sChr)
- sName = Replace(sName, "|", sChr)
- sName = Replace(sName, "&", sChr)
- sName = Replace(sName, "%", sChr)
- sName = Replace(sName, "*", sChr)
- sName = Replace(sName, " ", sChr)
- sName = Replace(sName, "{", sChr)
- sName = Replace(sName, "[", sChr)
- sName = Replace(sName, "]", sChr)
- sName = Replace(sName, "}", sChr)
- sName = Replace(sName, "!", sChr)
- End Sub
Kann ich schon den E-Mail Text und die PDF Anhänge super erstellen.
Jetzt möchte ich diese PDF-Dateien der Reihe nach (00.., 01,, usw.) zu einer machen. (Deshalb auch die Nummerierung am Anfang der Dateien)
Der Code (Zeile 63 – 73) läuft ohne Fehlermeldungen und so durch. Aber leider gibt es keine PDF-Datei. OK, dachte ich. der Code stammte ja auch aus einem VB.NET Projekt. Also schnell ein neues Testprojekt erstellt.
VB.NET-Quellcode
- Imports PDFSplitMerge
- Public Class Form1
- Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
- Dim Dateien As String
- Dim DateiSplit() As String
- Dim Ziel As String
- Dim pdf As Object
- Dateien = "C:\Temp\Outlook\00_Test-01.07.2020-10-58-23.pdf|C:\Temp\Outlook\01_Test-01.07.2020-10-58-23 3921_200701105659_001.pdf|C:\Temp\Outlook\02_Test-01.07.2020-10-58-23 3923_200701112544_001.pdf"
- pdf = New PDFSplitMerge.CPDFSplitMergeObj
- DateiSplit = Split(Dateien, "|")
- Ziel = Replace(DateiSplit(0), "00_", "99_")
- MsgBox(Ziel & vbCrLf & Dateien)
- pdf.Merge(Dateien, Ziel)
- pdf = Nothing
- End Sub
- End Class
Den Verweis auf die passende DLL noch schnell gesetzt und gestartet.
PDF wurde sauber und funktionsfähig erstellt. Also ist doch die DLL richtig installiert bzw. registriert und funktioniert.
(Die Pfade habe ich aus Outlook kopiert und hier nur eingefügt).
Jetzt halt meine Frage: Warum klappt das nicht mit Outlook? Oder gibt es da noch eine andere Möglichkeit?
Freundliche Grüße
Volker
P.S. In Anhang mal die DLL-Datei