C-UM-IGE_Macro classercourriel procedure

Objet: Configurer et utiliser la macro "Classercourriel" dans Outlook

Description

Cette procédure explique comment activer, configurer et utiliser la macro "Classercourriel" pour archiver vos courriels dans un dossier spécifique.

Etapes

Partie 1 : Activer l'onglet Développeur

1. Faites un clic droit sur la barre d'outils en haut d'Outlook et sélectionnez Personnaliser le ruban....

2. Dans la colonne de droite, sous Personnaliser le ruban, sélectionnez Onglets principaux dans le menu déroulant.
3. Cochez la case Développeur.
4. Cliquez sur OK pour fermer la fenêtre.

Partie 2 : Créer la macro

5. Allez dans le nouvel onglet Développeur et cliquez sur Macros.

6. Dans le champ Nom de la macro, tapez Classercourriel.
7. Cliquez sur Créer.

8. Effacez tout le texte présent dans la fenêtre de l'éditeur qui s'ouvre.
9. Copiez et collez le code suivant dans son intégralité :

   Sub Classercourriel()
   '
   '
   '
       Dim objItem As MailItem
       Dim objSelection As Selection
       Dim savePath As String
       Dim fileName As String
       Dim finalPath As String
   
       Dim strNamefrom As String
       Dim arrPartsfrom As Variant
       Dim strInitialsfrom As String
       Dim strNameto As String
       Dim arrPartsto As Variant
       Dim strInitialsto As String
   
   Dim i As Integer
   
   'Protection contre les erreurs
   On Error GoTo erreur
   'Appel d'une fonction pour déterminer le dossier où enregistrer
       savePath = PickFolderShell()
       If savePath = "" Then Exit Sub
       Set objSelection = Application.ActiveExplorer.Selection
       For Each objItem In objSelection
           If TypeName(objItem) = "MailItem" Then
   
               'création des initiales de
               ' Récupérer le nom complet du sender
               strNamefrom = objItem.senderName
               ' Découper le nom en mots (séparés par espace)
               arrPartsfrom = Split(strNamefrom, " ")
               ' Construire les initiales
               strInitialsfrom = ""
               For i = LBound(arrPartsfrom) To UBound(arrPartsfrom)
                   strInitialsfrom = strInitialsfrom & UCase(Left(arrPartsfrom(i), 1))
               Next i
               'création des initiales à
               ' Récupérer le nom complet du receiver
               strNameto = objItem.To
               ' Découper le nom en mots (séparés par espace)
               arrPartsto = Split(strNameto, " ")
               ' Construire les initiales
               strInitialsto = ""
               For i = LBound(arrPartsto) To UBound(arrPartsto)
                   strInitialsto = strInitialsto & UCase(Left(arrPartsto(i), 1))
               Next i
   
               'Création du nom du fichier à enregistrer
               'appel d'une fonction de nettoyage de nom pour enlever les caractères spéciaux
               fileName = Format(objItem.ReceivedTime, "yy-mm-dd") & " de " & _
                   CleanFileName(strInitialsfrom) & " a " & _
                   CleanFileName(strInitialsto) & " " & _
                   CleanFileName(objItem.Subject) & ".msg"
   
               finalPath = savePath & "\" & fileName
   
               objItem.SaveAs finalPath, olMSGUnicode
           End If
       Next
       MsgBox "Courriel enregitré avec succès!"
   Exit Sub
   erreur:
   MsgBox ("PROBLÈME !!!!! Le nom de votre fichier est probablement trop long ou existe déjà, veuillez sauvegarder manuellement le courriel")
   End Sub
   ' Function pour enlever les caractères invalides pour le nom
   Function CleanFileName(str As String) As String
       Dim invalidChars As Variant
       invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
       Dim i As Integer
       For i = LBound(invalidChars) To UBound(invalidChars)
           str = Replace(str, invalidChars(i), "_")
       Next i
       CleanFileName = Trim(str)
   End Function
   'Fonction pour sélectionner un répertoire d'enregistrement
   'répertoire de base dans le Z:
   Function PickFolderShell() As String
       Dim objShell As Object
       Dim objFolder As Object
       Dim objstartFolder As Object
       Set objShell = CreateObject("Shell.Application")
       Set objstartFolder = objShell.NameSpace("Z:\")
       Set objFolder = objShell.BrowseForFolder(0, "Choose save folder", 0, objstartFolder.Self.Path)
       If Not objFolder Is Nothing Then
           PickFolderShell = objFolder.Items().Item().Path
       Else
           PickFolderShell = ""
       End If
   End Function
   

10. Fermez la fenêtre de l'éditeur de code pour revenir à Outlook.

Partie 3 : Ajouter un bouton d'accès rapide

11. Faites à nouveau un clic droit sur le ruban et sélectionnez Personnaliser le ruban....

12. Dans la colonne de gauche, sous Choisir les commandes dans les catégories suivantes, sélectionnez Macros.
13. Sélectionnez la macro Classercourriel dans la liste.
14. Dans la colonne de droite, sélectionnez l'onglet où vous souhaitez ajouter le bouton (par exemple, Accueil (Courrier)), puis cliquez sur Nouveau groupe.
15. Assurez-vous que votre nouveau groupe est sélectionné, puis cliquez sur le bouton Ajouter >> au centre pour y placer la macro.
16. Cliquez sur le bouton Renommer... pour choisir une icône et donner un nom au bouton.
17. Cliquez sur OK pour fermer la fenêtre.

Partie 4 : Utiliser la macro

18. Sélectionnez le ou les courriels que vous souhaitez classer.
19. Cliquez sur le nouveau bouton que vous venez de créer dans le ruban pour exécuter la macro.

Remarques

• Si le changement d'icône n'a pas fonctionné, répétez les étapes 16 et 17.
• Si la macro affiche un message d'erreur, cela signifie que le courriel n'a pas pu être enregistré. Vous devez alors l'enregistrer manuellement.