Niquet.nl

E-mailbericht exporteren als PDF bestand

Met Windows 10 kwam de mooie functie waarmee je alle documenten die je naar de printer kunt sturen ook opslaan als PDF bestand.  Dus ook e-mailtjes in Outlook.
In VBA kom je dit echter niet tegen vreemd genoeg in de Outlook class. Deze vind je wel terug in MS-Word, dus via een omweg kan je via VBA toch een e-mailbericht opslaan als PDF bestand:

Sub SaveMessageAsPDF()
     
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
     Dim tmpfilename
     Dim MyDocs
     
    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 sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpfilename = FSO.GetSpecialFolder(2)
    
    sName = Item.subject
    ReplaceCharsForFileName sName, "-"
    tmpfilename = tmpfilename & "\" & sName & ".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")
    MyDocs = WshShell.SpecialFolders(16)
       
strToSaveAs = MyDocs & "\" & sName & ".pdf"
 
' Controleren of er al een bestand is met dezelfde naam
' als dit het geval is, dan wordt de tijd erachter gezet
If FSO.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".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
 
End Sub

Bovengenoemde code slaat het uiteindelijke PDF bestand op in de ‘default’ documenten-map.

Als je dit wilt vragen aan de gebruiker kan je onderstaande functie gebruiken:

Function SelecteerMap(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Selecteer de map waar u het PDF bestand wilt opslaan AUB", 0, OpenAt)
 
 On Error Resume Next
    SelecteerMap = ShellApp.self.Path
 On Error GoTo 0
 
 Set ShellApp = Nothing
    Select Case Mid(SelecteerMap, 2, 1)
        Case Is = ":"
            If Left(SelecteerMap, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(SelecteerMap, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function
 
Invalid:
 SelecteerMap = False
End Function



En deze functie kunt u dan als volgt gebruiken:

MyDocs = SelecteerMap
    
strToSaveAs = MyDocs & "\" & sName & ".pdf"
 
' Controleren of er al een bestand is met dezelfde naam
' als dit het geval is, dan wordt de tijd erachter gezet
If FSO.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If
'Verkenner openen en bestand selecteer  
Shell "C:\Windows\explorer.exe /select," & strToSaveAs, vbMaximizedFocus

 

Leave a Comment