Discussion :

[goninph]

Bonjour,

Est-il possible en cliquant sur un bouton de la barre des tâches d'enregistrer un mail dans un dossier de Windows via une boite de dialogue permettant de choisir le dossier et de corriger le nom du mail ?

Merci pour votre aide.
Meilleures salutations

J'ai trouvé ce code, mais il est trop direct, j'aimerai pouvoir choisir mon répertoire et modifier le nom du .msg

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Enregistrer_mail_sous_Windows()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Dim strPrompt As String
Dim strname As Variant
    Set myItem = Application.ActiveInspector
    If Not TypeName(myItem) = "Nothing" Then
        Set objItem = myItem.CurrentItem
        strname = objItem.Subject
        objItem.SaveAs "C:\Users\Philippe\Google Drive\A trier\" & strname & ".msg", olMSG
    Else
        MsgBox "There is no current active inspector."
    End If
End Sub

[goninph]

Bonsoir,

J'ai trouvé cette macro qui fonctionne à merveille.

Comment la modifier pour ouvrir une boite de dialogue afin de choisir le dossier du disque dur ?

Merci pour votre aide.

Meilleures salutations
Philippe

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
'Option Explicit
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
'By Oliv' juillet 2007 pour OUTLOOK 2003
 
    If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
    'Ici on construit le nom du fichier qui sera créé
    NomExport = objCurrentMessage.Subject & objCurrentMessage.CreationTime
 
    'Ici on défini le répertoire où l'enregistrer
    repertoire = "C:\Users\Philippe\Google Drive\A trier\"
 
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
    'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
    n = 1
    MemPath = PathNomExport
    While Dir(PathNomExport) <> ""
        MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
        PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
        n = n + 1
 
    Wend
    objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
 
End Sub
Sub Enregistrer_le_mail_ouvert_sous_Windows()
    sav_mail_as_msg
End Sub
Sub Enregistrer_la_selection_sous_Windows()
    Dim MonOutlook As Outlook.Application
    Dim LeMail As Object
    Dim LesMails As Outlook.Selection
    Set MonOutlook = Outlook.Application
 
    Set LesMails = MonOutlook.ActiveExplorer.Selection
 
    For Each LeMail In LesMails
        sav_mail_as_msg LeMail
    Next LeMail
 
    Set LesMails = Nothing
    MsgBox "Le mail est classer"
End Sub

[goninph]

Je progresse, je viens de trouver une fonction et j'ai adapté le code de la macro : sav_mail_as_msg et j'ai ajouté à la fin, l'ouverture du dossier pour vérifier si le fichier est bien classé

Maintenant j'aimerais pouvoir modifier le nom du mail à sauvegarder : blabla.msg

Des idées

Merci
A+ Philippe

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
60
61
62
'Option Explicit
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
    'By Oliv' juillet 2007 pour OUTLOOK 2003 adapté par Goninph 15.12.2020
    If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
    'Nom du fichier
    NomExport = objCurrentMessage.Subject '& objCurrentMessage.CreationTime
 
    'Répertoire où enregistrer
    strFolderpath = BrowseForFolder("C:\Users\Philippe\Google Drive\") 'Appel de la fonction < BrowseForFolder > pour choisir le dossier
    repertoire = strFolderpath & "\"
 
    'Suppression des caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
    'Si le fichier existe on incrémente de 1 le nom du fichier
    n = 1
    MemPath = PathNomExport
    While Dir(PathNomExport) <> ""
    PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
    n = n + 1
    Wend
    objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
 
    'Ouvrir le dossier pour vérifier si le fichier est bien classé
    Shell Environ("WINDIR") & "\explorer.exe " & repertoire, vbNormalFocus
End Sub
Sub Enregistrer_le_mail_ouvert_sous_Windows()
    sav_mail_as_msg
End Sub
Sub Enregistrer_la_selection_sous_Windows()
Dim MonOutlook As Outlook.Application
Dim LeMail As Object
Dim LesMails As Outlook.Selection
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    For Each LeMail In LesMails
        sav_mail_as_msg LeMail
    Next LeMail
    Set LesMails = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
            Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
                Case Else
            GoTo Invalid
        End Select
    Exit Function
Invalid:
BrowseForFolder = False
End Function

[goninph]

Bonjour,

Voilà j'ai réussi à adapter pour répondre à ma demande initiale

J'ai ajouté un formulaire avant de classer le mail.

Encore merci pour ce forum qui est génial avec des informations de qualités

Bonnes fêtes de fin d'année.
Meilleures salutations
Philippe

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
Option Explicit
Private Sub BT_Annuler_Click()
    Unload Me
End Sub
Private Sub BT_Retouche_Click()
    Me.TextBox_Objet_du_mail = "Retouches - " & Mail_Objet_original
End Sub
Private Sub BT_Signé_Click()
    Me.TextBox_Objet_du_mail = "Signé - " & Mail_Objet_original
    Me.TextBox_Objet_du_mail.SetFocus
End Sub
Private Sub BT_OK_Click()
    Mail_Objet = Me.TextBox_Objet_du_mail
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Me.TextBox_Objet_du_mail = Mail_Objet_original
    Me.TextBox_Objet_du_mail.SetFocus
End Sub

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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Option Explicit
Public Mail_Objet_original As Variant
Public Mail_Objet As Variant
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
Dim NomExport As Variant
Dim strFolderpath As Variant
Dim repertoire As Variant
Dim PathNomExport As Variant
Dim MemPath As Variant
Dim n As Variant
 
    'By Oliv' juillet 2007 pour OUTLOOK 2003 adapté par 'Goninph' 17.12.2020
    If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
    Mail_Objet_original = objCurrentMessage.Subject
 
    'Ouvrir formulaire pour la modification du nom de fichier du mail à classer
    USF_Modifier_Nom_Fichier.Show
 
    'Conserve le nom original du fichier si l'utilisateur clique sur la croix pour fermer le formulaire ou si le nom est effacé
    If Mail_Objet = "" Or USF_Modifier_Nom_Fichier.TextBox_Objet_du_mail = "" Then
            Exit sub
    End If
       'Nom du fichier
       NomExport = Mail_Objet '& objCurrentMessage.CreationTime
 
       'Chemin de l'enregistrement
       strFolderpath = BrowseForFolder("P:\Secteur Architectes\") 'Appel de la fonction < BrowseForFolder > pour choisir le dossier
       repertoire = strFolderpath & "\"
 
       'Suppression des caractères non autorisé dans les noms de fichiers
       PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
       NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
       'Si le fichier existe on incrémente de 1 le nom du fichier
       n = 1
       MemPath = PathNomExport
       While Dir(PathNomExport) <> ""
       PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
       n = n + 1
       Wend
       On Error GoTo Fin
       objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
 
    'Ouvrir le dossier pour vérifier si le fichier est bien classé
    Shell Environ("WINDIR") & "\explorer.exe " & repertoire, vbNormalFocus
    Mail_Objet = "" 'Vider la variable
Fin:
End Sub
Sub Enregistrer_le_mail_ouvert_sous_Windows()
    sav_mail_as_msg
End Sub
Sub Enregistrer_la_selection_sous_Windows()
Dim MonOutlook As Outlook.Application
Dim LeMail As Object
Dim LesMails As Outlook.Selection
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    For Each LeMail In LesMails
        sav_mail_as_msg LeMail
    Next LeMail
    Set LesMails = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
            Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
                Case Else
            GoTo Invalid
        End Select
    Exit Function
Invalid:
BrowseForFolder = False
End Function