Sauvegarde Mail sur disque

Version imprimable

Bonjour,

Accompagné d'exemples issus du forum j'ai écrit cette procédure vba dans Outlook 365.
Pour l'instant celle-ci est lancée par alt & F8 : le mail sélectionné est enregistre dans un dossier spécifique.

Celle-ci ne fonctionne que si le mail sélectionné à été affiché dans une fenêtre complémentaire de Outlook après un double click sur un mail !

Par contre elle ne fonctionne pas lorsque le mail sélectionné (simple click) s'affiche dans la même fenêtre Outlook principale.
En effet dans ce cas :
le TypeName(myItem) = "Nothing" alors le test du type est égale à Nothing et la procédure ne fonctionne pas.

En d'autre terme pour quelle raison le typename=nothing dans un cas et pas dans l'autre selon l'affichage du mail sélectionné 8O:roll: !!!
Code:

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 Option Explicit Public Sub SaveMail() '############################################################################# 'declaration Dim myItem As Outlook.Inspector Dim objItem As MailItem Dim strname As String Dim strPrompt As String Dim pth As String Dim d As String '############################################################################# 'initialisation 'objet Set myItem = Application.ActiveInspector 'string strPrompt = "Are you sure you want to save the item ?" pth = "C:\Users\Laurent\OneDrive\SaveItemMail\" strname = "Mail du " '############################################################################# 'procedure If Not TypeName(myItem) = "Nothing" Then Set objItem = myItem.CurrentItem d = Format(objItem.ReceivedTime, "yyyymmdd-hhmmss") strname = strname & d d = Format(Now, "yyyymmdd-hhmmss") strname = strname & " save " & d & ".msg" If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then objItem.SaveAs pth & strname Else MsgBox "There is no current active inspector." End If End Sub
Pourriez-vous me dire pour qu'elle raison svp ?
Avez vous rencontré ce problème ?
Merci par avance

Bonsoir,
N'ayant pas eu de réponse a ma question initiale, j'ai contourné le problème de la façon suivante :

Je n'utilise plus l'objet Application.ActiveInspector mais Application.ActiveWindow
et maintenant cela fonctionne.
Une fois qu'un Mail est sélectionné, je peux l'enregistrer dans un dossier spécifique, avec un nom déterminé et une extention ".msg"
Ici, la date de réception du mail et la date de sauvegarde.
Code:

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 Option Explicit Public Sub SaveMail() '############################################################################# 'declaration Dim myWindowItem As Object Dim myMailItem As MailItem Dim strname As String Dim strPrompt As String Dim pth As String Dim d As String '############################################################################# 'initialisation 'objet Set myWindowItem = Application.ActiveWindow 'string strPrompt = "Voulez-vous sauvegarder ce mail ?" pth = "C:\Users\Laurent\OneDrive\SaveItemMail\" strname = "Mail du " '############################################################################# 'procedure Set myMailItem = myWindowItem.Selection(1) If TypeName(myMailItem) = "MailItem" Then d = Format(myMailItem.ReceivedTime, "yyyymmdd-hhmmss") strname = strname & d d = Format(Now, "yyyymmdd-hhmmss") strname = strname & " save " & d & ".msg" If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then myMailItem.SaveAs pth & strname MsgBox "Mail sauvegardé." Else MsgBox "Pas de mail selectionné." End If End Sub
On peut lancer la procédure, soit avec alt & f8, soit en affectant la procédure a un bouton supplémentaire dans la barre de menu.
On peut ensuite imaginer une boite de dialogue avec un choix multiple de destination ......:D:D

Cela peut servir à quelqu'un.....

Bonne soirée

Bonjour,

Ci-dessous la macro que j'utilise tous les jours

Meilleures saluatations
Philippe

Code:

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
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
    'https://www.developpez.net/forums/d2098529/logiciels/microsoft-office/outlook/ouvrir-boite-dialogue-enregistrer-dossier-disque-dur/#post11661266
    Mail_Objet_original = "" 'Vider la variable
    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
'            Mail_Objet = Mail_Objet_original
    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