Exécuter macro sur le dernier email envoyé uniquement

**Oliv-** · 22/07/2019, 14h52

Envoyé par KASMINATOR

Merci de ta réponse.

La première partie c'est pour proposer une boite de dialogue pour enregistrer le fichier à l'endroit choisi par l'utilisateur.

J'ai remplacé mon strName par ta proposition mais toujours rien.

Le nom du fichier ne prend en charge que l'objet du mail.

Tu veux pouvoir choisir le dossier Windows où enregistrer le msg c'est bien cela ?

**KASMINATOR** · 22/07/2019, 14h56

Oui c'est çà qu'il me propose le dossier Windows où enregistrer le message.

Là actuellement je ne sais pas si tu as fait le test bah il ouvre bien la boite de dialogue et je peux choisir ou enregistrer le message.

Je vois même le nom du fichier avant d'enregistrer sous mais par contre comme nom du fichier actuellement je n'ai que l'objet du mail.

Franchement merci Oliv mille fois de m'aider !

**KASMINATOR** · 22/07/2019, 16h38

Je ne comprends vraiment pas pourquoi le nom du fichier reste figé uniquement sur l'objet du mail malgré que j'ai pu mettre le

Code :

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

Strname = Format(Item.CreationTime, "yymmdd") & " " & "AKA" & " " & Left(remplaceCaracteresInterdit(Item.Subject), 160)

Voici le code qui fonctionne sans renommer :

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
Dim WithEvents colSentItems As Items
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
          If MsgBox("Souhaitez-vous archiver l'email que vous venez d'envoyer?    ", vbSystemModal + vbYesNo, "par Amine KASMI") = vbNo Then Exit Sub
          Dim objFolder As Outlook.Folder
          Set objFolder = Application.Session.GetDefaultFolder(olFolderSentMail).Folders("Archivage")
          Set Item.SaveSentMessageFolder = objFolder
          Item.Save
End Sub
 
Private Sub Application_Startup()
 
    Dim NS As Outlook.NameSpace
    Set NS = Application.GetNamespace("MAPI")
 
'#########################################################
Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).Folders("Archivage").Items
'#########################################################
 
 
End Sub
 
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
'By Oliv ' janv 2008 pour Outlook 2003 feat. Sue Mosher
'http://www.outlookcode.com/codedetail.aspx?id=456
If Item.Class = olMail Then
Strname = Format(Item.CreationTime, "yymmdd") & " " & "AKA" & " " & Left(remplaceCaracteresInterdit(Item.Subject), 160)
          Item.Display
          Dim objInsp
          Dim colCB
          Dim objCBB
          On Error Resume Next
          Set objInsp = Item.GetInspector
          Set colCB = objInsp.CommandBars
          Set objCBB = colCB.FindControl(, 748) 'enregistrer  sous
          If Not objCBB Is Nothing Then
              objCBB.Execute
          End If
          Item.Close olDiscard
         End If
 
 End Sub
 
 
 
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
    Dim objCurrentMessage As Outlook.MailItem
 
    Dim liste As Variant
    Dim L
    liste = Array("\", "/", ":", "*", "?", "<", ">", "|", ".", """", vbTab, Chr(7))
    For L = 0 To UBound(liste)
        CheminStr = Replace(CheminStr, liste(L), "")
    Next L
    remplaceCaracteresInterdit = CheminStr
    'MsgBox CheminStr
End Function

**Oliv-** · 22/07/2019, 16h48

Première chose, quand tu publies du code entoure le en cliquant su l'icone #

En fait comme le traitement est asynchrone, entre le moment où tu envoies et le moment où le mail est classé, il faudrait poser la question à la première étape (Application_ItemSend) et tu stockes cette info dans l'Email :

Code :

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

1
2
Item.BillingInformation="c:\temp\archivage\aka\"
item.save

par contre avec la boite de dialogue que tu obtiens avec Set objCBB = colCB.FindControl(, 748) 'enregistrer sous il me semble que tu ne peux pas proposer de nom de fichier.

je cherche dans mes codes et reviendrais vers toi

**KASMINATOR** · 22/07/2019, 16h53

C'est ce que j'ai essayé de faire... je ne sais pas si tu as fais un test par hasard chez toi mais en tout cas sache que la boite de dialogue s'ouvre très bien et seul le nom d'enregistrement pose problème sinon tout est top

Merci encore de m'aider oliv et j'espère que la macro finalisée pourra profiter à d'autres.

Bien évidemment si tu penses qu'une autre boite de dialogue pourrait être utilisée je suis preneur. Je suis prêt à changer.

**Oliv-** · 22/07/2019, 17h11

dans cette discussion plusieurs méthodes
https://www.developpez.net/forums/d1...courci-bureau/

**KASMINATOR** · 23/07/2019, 08h28

Merci Oliv mais çà ne correspond pas vraiment, j'aimerai pouvoir rectifier juste le nom sans repartir d'une solution trop compliquée à mon niveau...

Merci quand même et passe une belle journée

**Oliv-** · 23/07/2019, 11h32

Essaye ce code

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
96
97
98
Dim WithEvents colSentItems As Items
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Item.Class = olMail Then
        If MsgBox("Souhaitez-vous archiver l'email que vous venez d'envoyer?    ", vbSystemModal + vbYesNo, "par Amine KASMI") = vbNo Then Exit Sub
 
        Dim objFolder As Outlook.Folder
        Set objFolder = Application.Session.GetDefaultFolder(olFolderSentMail).Folders("Archivage")
        Set Item.SaveSentMessageFolder = objFolder
 
        Item.BillingInformation = BrowseForWindowsFolder("c:\user\" & Environ("username"))
        Item.Save
    End If
End Sub
 
Private Sub Application_Startup()
 
    Dim NS As Outlook.NameSpace
    Set NS = Application.GetNamespace("MAPI")
 
    '#########################################################
    Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).Folders("Archivage").Items
    '#########################################################
 
 
End Sub
 
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
'By Oliv ' janv 2008 pour Outlook 2003 feat. Sue Mosher
'http://www.outlookcode.com/codedetail.aspx?id=456
    If Item.Class = olMail Then
 
        'ça c'est le dossier où enregistrer ! attention il faut un "\" à la fin
        If Dir(Item.BillingInformation, vbDirectory) <> "" Then
 
            repertoire = Item.BillingInformation
            If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
 
            'ça c'est le nom du fichier
            strName = Format(Item.CreationTime, "yymmdd") & " " & "AKA" & " " & Left(remplaceCaracteresInterdit(Item.Subject), 160)
 
            ' là on enregistre
 
            Item.SaveAs repertoire & strName & ".msg", OlSaveAsType.olMSG
        End If
 
 
    End If
End Sub
 
 
 
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
    Dim objCurrentMessage As Outlook.MailItem
 
    Dim liste As Variant
    Dim L
    liste = Array("\", "/", ":", "*", "?", "<", ">", "|", ".", """", vbTab, Chr(7))
    For L = 0 To UBound(liste)
        CheminStr = Replace(CheminStr, liste(L), "")
    Next L
    remplaceCaracteresInterdit = CheminStr
    'MsgBox CheminStr
End Function
 
 
Function BrowseForWindowsFolder(Optional OpenAt As Variant) As Variant
'---------------------------------------------------------------------------------------
' Procedure : BrowseForWindowsFolder
' Author    : Diane Poremsky
' Date      : 23/07/2019
' Purpose   : https://www.slipstick.com/developer/code-samples/windows-filepaths-macro/
'---------------------------------------------------------------------------------------
'
 
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
            BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
    On Error Resume Next
    BrowseForWindowsFolder = ShellApp.self.Path
    On Error GoTo 0
 
    Set ShellApp = Nothing
    Select Case Mid(BrowseForWindowsFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForWindowsFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForWindowsFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
    Exit Function
 
Invalid:
    BrowseForWindowsFolder = False
End Function

n'oubli pas de lancer Application_Startup