Discussion :

[Cathare2020]

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é !!!

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
 
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

[Cathare2020]

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 :

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
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 ......

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

Bonne soirée

[goninph]

Bonjour,

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

Meilleures saluatations
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
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