Choisir le répertoire d'enregistrement d'un mail

**tipack** · 14/05/2018, 12h10

Bonjour,

Je voudrais écrire une macro pour enregistrer un mail sur mon ordinateur avec un nom personnalisé.

J'ai réussi à personnaliser le nom du fichier comme je le souhaitait (JJMMAAAA_HHMM_EXP_OBJ.msg) et à l'enregistrer dans un dossier qui est défini par l'utilisateur avec une boîte de dialogue et qui a une valeur par défaut avec le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim sSenderEmailAddress As String
  Dim res As Integer
  Dim xlDialogSaveAs
 
  Dim Message, Title, Default, MyValue
            Message = "Où voulez-vous enregistrer la sélection ?"
            Title = "Sélection du répertoire de sauvegarde "
            Default = "C:\Users\packt\Desktop\CopieMail\"
            sPath = InputBox(Message, Title, Default)
 
   For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
 
            sName = oMail.Subject
            sName = StrConv(sName, vbProperCase)
            ReplaceCharsForFileName sName, ""
 
            dtDate = oMail.ReceivedTime
 
            sSenderEmailAddress = oMail.SenderName
            res = InStr(1, sSenderEmailAddress, ",")
            If res = 0 Then
                sSenderEmailAddress = Left(sSenderEmailAddress, 10)
            Else
                sSenderEmailAddress = Left(sSenderEmailAddress, InStr(sSenderEmailAddress, ",") + 2)
            End If
            ReplaceCharsForFileName sSenderEmailAddress, ""
 
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & "_" & Format(dtDate, "hhnn", _
                vbUseSystemDayOfWeek, vbUseSystem) & "_" & sSenderEmailAddress & "_" & sName & ".msg"
 
 
            oMail.SaveAs sPath & sName, olMSG
        End If
   Next
End Sub
 
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
  sName = Replace(sName, " ", sChr)
  sName = Replace(sName, ",", sChr)
End Sub

Ce que je voudrais savoir maintenant c'est comment rendre le choix du dossier un peu plus intuitif à la manière de l'option "Enregistrer Sous" en parcourant les dossier.
J'ai vu qu'il existe plusieur solution mais je débute sur VBA et c'est ma première macro. Je ne sais pas encore comment tout cela fonctionne et comment organiser mes fichiers et à chaque fois que je teste une solution je me retrouve des erreurs que je n'arrive pas à corriger.

Existe-t-il un moyen simple de faire ce que voudrais ?
Merci d'avance pour votre aide !