Discussion :

[ayeross]

Bonjour,

J'en appelle à votre bon cœur.

J'aurai besoin d'aide pour améliorer le code de 'By Oliv' juillet 2007 pour OUTLOOK 2003

https://outlook.developpez.com/faq/?...#VBA_save_mail

Je travaille actuellement avec Outlook 2016 et la ligne de code dédiée au choix du dossier de destination ne fonctionne pas/ou plus sur OL2016.

repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"


J'ai déjà réussi à l'améliorer en utilisant oShell.browseforfolder, qui m'affiche la fenêtre explorateur pour sélectionner le dossier.
Le problème est que lorsque plusieurs mails sont sélectionnés, je dois de nouveau définir le dossier pour chaque mail, plutôt que d'enregistrer toute la sélection dans un seul.
Je présume que je dois jongler avec la boucle suivante mais mon savoir s'arrête ici:

For Each LeMail In LesMails
sav_mail_as_msg LeMail
Next LeMail

_______________
Code ______________________________

Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
Dim oShell As Object
Dim save_to_folder As Object
Set oShell = CreateObject("Shell.Application")
If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem

'Extraction et formatage de la date
Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
'Ici on construit le nom du fichier qui sera créé
nomexport = Annee & "-" & Mois & "-" & Jour & "-" & Heure & "-" & " " & objCurrentMessage.Subject & "-" & objCurrentMessage.SenderName

'Ici on défini le répertoire où l'enregistrer
'repertoire = "c:\temp\"
Set save_to_folder = oShell.browseforfolder(0, "Séléctionner dossier d'archivage:", 1)
If save_to_folder Is Nothing Then Exit Sub
repertoire = save_to_folder.ParentFolder.ParseName(save_to_folder.Title).Path & "\"

'Ici on supprime les caractères non autorisé dans les noms de fichiers
PathNomExport = repertoire & 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 LanceSurOuvert()

sav_mail_as_msg
RangerMailCategory
End Sub


Sub LanceSurSelection()
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 "Votre mail a été archivé"
RangerMailCategory
End Sub

[Invité]

Le problème est que lorsque plusieurs mails sont sélectionnés, je dois de nouveau définir le dossier pour chaque mail, plutôt que d'enregistrer toute la sélection dans un seul.
Je présume que je dois jongler avec la boucle suivante mais mon savoir s'arrête ici:

Bonjour,

Lorsque vous postez, mettez votre code entre balises #.

Il vous faut, pour cela, définir le répertoire en amont de la procédure Sav_Mail_As_Msg et lui donner le nom du répertoire en paramètre.
Le code ci-dessous est une piste de ce que vous pourriez faire, mais je ne l'ai pas testé.

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
83
84
85
86
87
88
89
90
91
92
93
94
95
 
Option Explicit
 
Private oShell As Object
Private Save_To_Folder As Object
Private MonRepertoire As String
 
Sub Sav_Mail_As_Msg_Modifie(ByVal Repertoire As String, Optional ObjCurrentMessage As Object)
 
Dim NomExport As String, PathNomExport As String, Annee As String, Mois As String, Jour As String, Heure As String, MemPath As String
Dim N As Integer
 
 
'Dim oShell As Object
'Dim Save_To_Folder As Object
 
 '   Set oShell = CreateObject("Shell.Application")
    If ObjCurrentMessage Is Nothing Then Set ObjCurrentMessage = ActiveInspector.CurrentItem
 
    'Extraction et formatage de la date
    Annee = Mid(ObjCurrentMessage.CreationTime, 7, 4)
    Mois = Mid(ObjCurrentMessage.CreationTime, 4, 2)
    Jour = Mid(ObjCurrentMessage.CreationTime, 1, 2)
    Heure = Mid(ObjCurrentMessage.CreationTime, 12, 5)
 
    'Ici on construit le nom du fichier qui sera créé
    With ObjCurrentMessage
         NomExport = Annee & "-" & Mois & "-" & Jour & "-" & Heure & "-" & " " & .Subject & "-" & .SenderName
    End With
 
    'Ici on défini le répertoire où l'enregistrer
    'repertoire = "c:\temp\"
 
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = Repertoire & 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 LanceSurOuvert()
 
    Set oShell = CreateObject("Shell.Application")
    Set Save_To_Folder = oShell.browseforfolder(0, "Séléctionner dossier d'archivage:", 1)
 
    If Save_To_Folder Is Nothing Then Exit Sub
 
    MonRepertoire = Save_To_Folder.ParentFolder.ParseName(Save_To_Folder.Title).Path & "\"
 
    Sav_Mail_As_Msg_Modifie MonRepertoire
    RangerMailCategory
 
    Set oShell = Nothing
    Set Save_To_Folder = Nothing
 
End Sub
 
Sub LanceSurSelection()
 
Dim MonOutlook As Outlook.Application
Dim LeMail As Object
Dim LesMails As Outlook.Selection
 
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    Set oShell = CreateObject("Shell.Application")
    Set Save_To_Folder = oShell.browseforfolder(0, "Séléctionner dossier d'archivage:", 1)
 
    If Save_To_Folder Is Nothing Then Exit Sub
 
    MonRepertoire = Save_To_Folder.ParentFolder.ParseName(Save_To_Folder.Title).Path & "\"
 
    For Each LeMail In LesMails
        Sav_Mail_As_Msg_Modifie MonRepertoire, LeMail
    Next LeMail
 
    Set LesMails = Nothing
 
    'MsgBox "Votre mail a été archivé"
    RangerMailCategory
 
    Set oShell = Nothing
    Set Save_To_Folder = Nothing
    Set MonOutlook = Nothing
 
End Sub

• Option Explicit va vous forcer à déclarer vos variables...
• Les variables oShell, Save_To_Folder, MonRepertoire sont déclarées en tête du module car elles servent dans deux procédures du même module.
• RangerMailCategory n'étant pas présent dans votre message, je ne peux dire l'incidence de la destruction des variables :
  

  Code :

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

  1
  2
  3
  4
   
      Set oShell = Nothing
      Set Save_To_Folder = Nothing
      Set MonOutlook = Nothing

[Oliv-]

Bonjour,

Voir ici une évolution, j'ai pas lu si cela répond entièrement au besoin

https://www.developpez.net/forums/bl...le-disque-msg/