Sous Microsoft Outlook (sous Windows), possibilité de créer une macro VBA simple et l’associer à un bouton de la barre d’outils “Accès rapide”.
Création de la Macro :
- Ouvrir l’éditeur Microsoft Visual Basic pour Applications depuis votre fenêtre Outlook : Alt + F11
- Créer un module
- null
- Coller ce bout de code
Sub SaveAsPDFfile()
'====================================================
' Description: Outlook macro to save a selected item in the pdf-format
' Requires Word 2007 SP2 or Word 2010
' Requires a reference to "Microsoft Word Object Library"
' (version is 12.0 or 14.0)
' In VBA Editor; Tools-> References…
'
' author: Robert Sparnaaij
' website: http://www.howto-outlook.com/howto/saveaspdf.htm
'
' Complété et modifié le 24/08/2017 par HGD :
' + ajout du numéro de page en pied de page
' + modification du nom de fichier proposé par défaut pour un format "AAAAMMJJ-HHhmm-Email_Expéditeur"
' + modification du dossier de sauvegarde par défaut (Bureau)
' + ouverture du pdf et de l'explorateur Windows en fin de processsus
'
'====================================================
'Get all selected items Dim MyOlNamespace As Outlook.NameSpace Set MyOlNamespace = Application.GetNamespace("MAPI") Set MyOlSelection = Application.ActiveExplorer.Selection 'Make sure at least one item is selected If MyOlSelection.Count <> 1 Then Response = MsgBox("Please select a single item", vbExclamation, "Save as PDF") Exit Sub End If 'Retrieve the selected item Set MySelectedItem = MyOlSelection.Item(1) '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 = "testPDFOutlook03" tmpFileName = tmpFileName & "\" & strName & ".mht" 'Save the mht-file MySelectedItem.SaveAs tmpFileName, olMHTML 'Create a Word object Dim wrdApp As Word.Application Dim wrdDoc As Word.Document Set wrdApp = CreateObject("Word.Application") 'Open the mht-file in Word without Word visible Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False) ' HGD le 24/08/2017 : Ajout des numéros de page en pied de page central wrdDoc.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _ PageNumberAlignment:=wdAlignPageNumberCenter ' et pas testé complètement, mais à tester et affiner si on souhaite les numéros de page aussi (issu d'un enregistrement de macro sous Word)
' If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
' ActiveWindow.Panes(2).Close
' End If
' If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
' ActivePane.View.Type = wdOutlineView Then
' ActiveWindow.ActivePane.View.Type = wdPrintView
' End If
' ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
' Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
' Selection.TypeText Text:="Page "
' Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
' "PAGE ", PreserveFormatting:=True
' Selection.TypeText Text:=" / "
' Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
' "NUMPAGES ", PreserveFormatting:=True
' Selection.Font.Bold = wdToggle
' Selection.Font.Size = 10
' Selection.Font.Name = "Arial"
' Selection.Font.Name = "Calibri"
' ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
'Define the SaveAs dialog Dim dlgSaveAs As FileDialog Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs) 'Determine the FilterIndex for saving as a pdf-file 'Get all the filters Dim fdfs As FileDialogFilters Dim fdf As FileDialogFilter Set fdfs = dlgSaveAs.Filters 'Loop through the Filters and exit when "pdf" is found Dim i As Integer i = 0 For Each fdf In fdfs i = i + 1 If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then Exit For End If Next fdf 'Set the FilterIndex to pdf-files dlgSaveAs.FilterIndex = i 'Get location of My Documents folder Dim WshShell As Object Dim SpecialPath As String Set WshShell = CreateObject("WScript.Shell") SpecialPath = WshShell.SpecialFolders("Desktop") ' HGD le 24/08/2017 : voir <http://excel-malin.com/codes-sources-vba/trouver-chemin-de-bureau/> ' Formule initiale vers "Mes Documents" avec SpecialPath = WshShell.SpecialFolders(16) 'Construct a safe file name from the message subject Dim msgFileName As String msgFileName = MySelectedItem.ReceivedTime ' HGD le 24/08/2017 : rend quelque chose du genre "24/08/2017 15:07:30" ' Formule initiale avec comme nom de fichier le Sujet du mail : msgFileName = MySelectedItem.Subject ' HGD le 24/08/2017 : Construction d'un nom de type "AAAAMMJJ-HHhmm-Email_Expéditeur" Dim AAAA, MM, JJ, HH, min, ss As String JJ = Left(msgFileName, 2) MM = Right(Left(msgFileName, 5), 2) AAAA = Right(Left(msgFileName, 10), 4) HH = Right(Left(msgFileName, 13), 2) min = Right(Left(msgFileName, 16), 2) ss = Right(Left(msgFileName, 19), 2) msgFileName = AAAA & MM & JJ & "-" & HH & "h" & min ' & "-" & ss ' (pas besoin des secondes) msgFileName = msgFileName & "-Email_" & MySelectedItem.SenderName Set oRegEx = CreateObject("vbscript.regexp") oRegEx.Global = True oRegEx.Pattern = "[\\/:*?""<>|]" msgFileName = Trim(oRegEx.Replace(msgFileName, "")) 'Set the initial location and file name for SaveAs dialog Dim strCurrentFile As String dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName 'Show the SaveAs dialog and save the message as pdf If dlgSaveAs.Show = -1 Then strCurrentFile = dlgSaveAs.SelectedItems(1) 'Verify if pdf is selected If Right(strCurrentFile, 4) <> ".pdf" Then Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _ vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel) If Response = vbCancel Then wrdDoc.Close wrdApp.Quit Exit Sub ElseIf Response = vbOK Then intPos = InStrRev(strCurrentFile, ".") If intPos > 0 Then strCurrentFile = Left(strCurrentFile, intPos - 1) End If strCurrentFile = strCurrentFile & ".pdf" End If End If 'Save as pdf wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _ strCurrentFile, 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 End If Set dlgSaveAs = Nothing ' close the document and Word wrdDoc.Close wrdApp.Quit ' HGD le 24/08/2017 : Ouverture de l'explorateur Windows en fin de processus ' voir https://excel.developpez.com/faq/index.php?page=FichiersDir#OuvreExploWindows Dim MonFichier As String MonFichier = SpecialPath Shell "C:\windows\explorer.exe " & MonFichier, vbMaximizedFocus ' HGD le 24/08/2017 : Ouverture du fichier pdf en fin de processus (pour visu et vérification) ' voir http://excel-malin.com/codes-sources-vba/vba-ouvrir-un-fichier-de-tout-type/ Dim MonApplication As Object Set MonApplication = CreateObject("Shell.Application") MonFichier = SpecialPath & "\" & msgFileName & ".pdf" MonApplication.Open (MonFichier) Set MonApplication = Nothing 'Cleanup Set MyOlNamespace = Nothing Set MyOlSelection = Nothing Set MySelectedItem = Nothing Set wrdDoc = Nothing Set wrdApp = Nothing Set oRegEx = Nothing
End Sub
- Adapter les éléments en gras à ce que vous souhaitez et fermer l’éditeur en sauvegardant.
Création du bouton et affectation de la macro
- Ouvrir la fenêtre des Options Outlook : voir image ci-dessous.
- Sélectionner “Macros” dans les catégories de commandes à afficher
- Puis la Macro à ajouter et enfin “Ajouter” (bouton au milieu).
- Vous pouvez ensuite modifier le “Nom” du bouton, et son symbole.
- Accéder rapidement à l’action via le bouton qui s’affiche dans la barre tout en haut