Étiquette : Macro VBA

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