Outlook Outlook imprimer mail et PJ en PDF

Sub SaveAllAsPDFfile()

'=================================================================
'Description: Outlook macro to save all selected items in the
'             pdf-format.
'
'Important!   This macro requires a reference added to the
'             Microsoft Word <version> Object Library
'             In VBA Editor: Tools-> References...
'
'author : Robert Sparnaaij
'version: 2.0
'website: https://www.howto-outlook.com/howto/saveaspdf.htm
'=================================================================

    'Get all selected items
    Dim objOL As Outlook.Application
    Dim objSelection As Outlook.Selection
    Dim objItem As Object
    Set objOL = Outlook.Application
    Set objSelection = objOL.ActiveExplorer.Selection

    'Make sure at least one item is selected
    If objSelection.Count > 0 Then

        'Get the user's TempFolder to store the item in
        Dim FSO As Object, TmpFolder As Object
        Set FSO = CreateObject("scripting.filesystemobject")
        Set tmpFileName = FSO.GetSpecialFolder(2)

        'construct the filename for the temp mht-file
        strName = "www_howto-outlook_com"
        tmpFileName = tmpFileName & "\" & strName & ".mht"

        'Create a Word object
        Dim wrdApp As Word.Application
        Dim wrdDoc As Word.Document
        Set wrdApp = CreateObject("Word.Application")

        'Get location of the Documents folder
        Dim WshShell As Object
        Dim SpecialPath As String
        Set WshShell = CreateObject("WScript.Shell")
        DocumentsPath = WshShell.SpecialFolders(16)

        'Show Select Folder dialog for output files
        Dim dlgFolderPicker As FileDialog
        Set dlgFolderPicker = wrdApp.FileDialog(msoFileDialogFolderPicker)
        dlgFolderPicker.AllowMultiSelect = False
        dlgFolderPicker.InitialFileName = DocumentsPath

        If dlgFolderPicker.Show = -1 Then
            strSaveFilePath = dlgFolderPicker.SelectedItems.Item(1)
        Else
            Result = MsgBox("No folder selected. Please select a folder.", _
                      vbCritical, "SaveAllAsPDFfile")
            wrdApp.Quit
            Exit Sub
        End If

        For Each objItem In objSelection

            'Save the mht-file
            objItem.SaveAs tmpFileName, olMHTML

            'Open the mht-file in Word without Word visible
            Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False)

            'Construct the unique file name to prevent overwriting.
            'Here we base it on the ReceivedDate and the subject.
            'Feel free to alter the file name defintion and date/time format to your liking
            Dim strFileName As String
            Dim DateTimeFormatted As String
            DateTimeFormatted = Format(objItem.ReceivedTime, "yyyy-mm-dd_hh-mm-ss")
            strFileName = objItem.senderName & " - " & DateTimeFormatted & " - " & objItem.Subject
            ' strFileName = obj.SenderEmailAddress & " - " & objItem.senderName & " - " & DateTimeFormatted & " - " & objItem.Subject---> CA MARCHE PAS
            'Make sure the file name is safe for saving
            Set oRegEx = CreateObject("vbscript.regexp")
            oRegEx.Global = True
            oRegEx.Pattern = "[\/:*?""<>|]"
            strFileName = Trim(oRegEx.Replace(strFileName, "-"))

            'Construct save path
            strSaveFileLocation = strSaveFilePath & "\" & strFileName

            'Save as pdf
            wrdDoc.ExportAsFixedFormat OutputFileName:= _
                strSaveFileLocation, 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

            'Close the current document
            wrdDoc.Close
        Next
        
        'Close Word
        wrdApp.Quit

    'Oops, nothing is selected
    Else
        Result = MsgBox("No item selected. Please make a selection first.", _
                  vbCritical, "SaveAllAsPDFfile")
        Exit Sub
    End If

    'Cleanup
    Set objOL = Nothing
    Set objSelection = Nothing
    Set FSO = Nothing
    Set tmpFileName = Nothing
    Set WshShell = Nothing
    Set dlgFolderPicker = Nothing
    Set wrdApp = Nothing
    Set wrdDoc = Nothing
    Set oRegEx = Nothing

End Sub