Discussion :

[KASMINATOR]

Bonjour à tous,

J'ai réussi à faire fonctionner une macro grâce aux travaux d'Olivier LEBEAU que vous pourrez retrouver ci dessous :

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
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
 
   If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
 
 
 
    NomExport = Format(objCurrentMessage.CreationTime, "yymmdd") & "  " & "AKA" & "   " & objCurrentMessage.Subject
    repertoire = BrowseForFolder("Choisissez la destination")
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
    n = 1
        'Ici on défini le répertoire où l'enregistrer donc c'est à ce moment que la boite de dialogue va s'ouvrir
    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

Par contre je n'arrive pas à l’exécuter uniquement sur le dernier mail envoyé.

Merci de votre aide.

NH2

[Oliv-]

Bonjour,

Il faut utiliser un événement celui d'ajout d'un élément dans un dossier, en l'occurrence les "éléments envoyés"


Dans thisOutlookSession

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
Dim WithEvents colSentItems As Items
 
Private Sub Application_Startup()
 
    Dim NS As Outlook.NameSpace
    Set NS = Application.GetNamespace("MAPI")
 
 
Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).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
        repertoire = "C:\temp\"
 
 
            ' 1ère façon sans boite de dialogue on connait l'endroit où enregistrer
    strName = repertoire & "Email " & Left(remplaceCaracteresInterdit(Item.Subject), 160)
 
' sinon on ouvre une une recherche de dossier
            'Repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
 
 
            Item.SaveAs strName & ".msg", OlSaveAsType.olMSG
 
 
    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

[KASMINATOR]

MERCI oliv

Justement dans thisOutlookSession, j'avais simplement mis l'événement suivant :

Code :

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

1
2
3
Public Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Call sav_mail_as_msg
End Sub

[Oliv-]

ALors en fait le Application_ItemSend gère le message juste avant son envoi, l'autre événement va gèrer le message juste après son envoi , à condition qu'il soit bien classé dans les élément envoyés

[KASMINATOR]

Merci Oliv

çà ne fonctionne toujours pas pourtant dans thisOutlookSession j'ai rajouté ta proposition.

Il ne serait pas plus "simple" de rajouter une condition If dans :

Code :

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

1
2
3
Public Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Call sav_mail_as_msg
End Sub

Pour l'instant j'ai la macro : sav_mail_as_msg dans un module. Tu suggères de mettre cette macro dans thisOutlookSession également?

[KASMINATOR]

En réalité j'arrive à enregistrer l'email mais je n'enregistre pas l'email envoyé mais j'enregistre l'email avant son envoi...

Tu pourrais m'aider stp Oliv ?

Voici le détail dans This Outlook Session

Code :

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

1
2
3
4
Public Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If MsgBox("Souhaitez-vous archiver l'email que vous venez d'envoyer?", vbQuestion + vbYesNo, "confirmation") = vbNo Then Exit Sub
Call KASMINATOR
End Sub

La Macro KASMINATOR est la suivante :

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
Sub KASMINATOR()
    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 "Fin de traitement"
End Sub

[KASMINATOR]

J'ai essayé plusieurs solutions mais impossible de réussir à sélectionner uniquement le dernier mail envoyé après son envoi

[Oliv-]

alors du coup c'est un peu plus compliqué si tu veux avoir le choix lors de l'envoi (c'est bien Application_ItemSend qu'il faut utiliser ici)

Tu as plusieurs façons de la faire

Soit tu créés un dossier spécifique pour l'archivage

par exemple un sous dossier de "éléments envoyés" et tu utilises la macro que je t'ai donné comme cela (parties #########)

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
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?", vbQuestion + vbYesNo, "confirmation") = 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
        repertoire = "C:\temp\"
 
 
            ' 1ère façon sans boite de dialogue on connait l'endroit où enregistrer
    strName = repertoire & "Email " & Left(remplaceCaracteresInterdit(Item.Subject), 160)
 
' sinon on ouvre une une recherche de dossier
            'Repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
 
 
            Item.SaveAs strName & ".msg", OlSaveAsType.olMSG
 
 
    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

Soit tu indiques une info dans une propriété de ton Email qui va te permettre de savoir que tu dois l'archiver lors du déclenchement de colSentItems_ItemAdd

[Oliv-]

la seconde méthode

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
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?", vbQuestion + vbYesNo, "confirmation") = vbNo Then Exit Sub
          Item.BillingInformation="archivage"
          item.save
End Sub
 
Private Sub Application_Startup()
 
    Dim NS As Outlook.NameSpace
    Set NS = Application.GetNamespace("MAPI")
 
'######################################################### 
Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).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
 
if item.BillingInformation="archivage" then
        repertoire = "C:\temp\"
 
 
            ' 1ère façon sans boite de dialogue on connait l'endroit où enregistrer
    strName = repertoire & "Email " & Left(remplaceCaracteresInterdit(Item.Subject), 160)
 
 
            Item.SaveAs 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

[KASMINATOR]

Je vais paraître nulle.. vraiment je suis un peu vert car tout s'exécute très bien sauf que le mail choisi pour la sauvegarde n'est pas le mail envoyé..

Je n'arrive pas à comprendre ta solution dans le sens dois-je mettre toute la macro complète Thisoutlooksession ?

[Oliv-]

Oui tu dois tout mettre à cet endroit

petite explication , quand l'événement se déclenche, ici ajout du mail dans le dossier après l'envoi

Code :

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

colSentItems_ItemAdd(ByVal Item As Object)

Tu vois dans la parenthèse, l'événement reçoit un objet ITEM qui représente le mail en question

du coup tu travailles avec cet Email et tu n'as pas à le chercher

[KASMINATOR]

Merci Oliv en tout cas même si je désespère d'y arriver un jour...

J'ai bien la proposition d'archiver ou non mais çà n'ouvre plus du tout la boite de dialogue pour me proposer d’enregistrer l'e-mail envoyé comme auparavant.

J'ai compilé toutes les procédures dans This Outlook session comme tu m'as dis.

Le code toi + moi donne le résultat suivant :

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
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?", vbQuestion + vbYesNo, "confirmation") = vbNo Then Exit Sub
          Item.BillingInformation = "archivage"
          Item.Save
End Sub
 
Private Sub Application_Startup()
 
    Dim NS As Outlook.NameSpace
    Set NS = Application.GetNamespace("MAPI")
 
'#########################################################
Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).Items
'#########################################################
 
 
End Sub
 
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
'Dim MonOutlook As Outlook.Application
 
 
   If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
 
        'Ici on construit le nom du fichier qui sera créé DONC VOUS DEVEZ SIMPLEMENT REMPLACER AKA par
 
 
     NomExport = Format(objCurrentMessage.CreationTime, "yymmdd") & "  " & "AKA" & "   " & objCurrentMessage.Subject
    Repertoire = BrowseForFolder("Choisissez la destination")
    PathNomExport = Repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
    n = 1
        'Ici on défini le répertoire où l'enregistrer donc c'est à ce moment que la boite de dialogue va s'ouvrir
    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
 
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
  Dim objShell   As Object
    Dim ssfWINDOWS As Long
    Dim objFolder  As Object
 
    ssfWINDOWS = 36
    Set objShell = CreateObject("Shell.Application")
 
        Set objFolder = objShell.BrowseForFolder(0, Title, 0, ssfWINDOWS)
            If (Not objFolder Is Nothing) Then
            BrowseForFolder = objFolder.self.Path & "\"
                        End If
        Set objFolder = Nothing
    Set objShell = Nothing
 
End Function
 
 
Sub AKA()
    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 "Fin de traitement - KASMINATOR"
End Sub

[Oliv-]

Bonjour,

Ton mixe de code n'est pas bon.

As tu essayé simplement de mettre mon code en entier sans le changer ? est-ce qu'il fonctionne ?

[KASMINATOR]

Bonjour Oliv et merci encore pour toutes tes bonnes idées.

Oui j'ai tout supprimé hier et copier-coller ta proposition mais çà n'a pas archivé l'email envoyé.. tu penses que dans mon mix de code quel serait la mauvaise manipulation?

J'hésite à rajouter une partie de code qui indiquerait d'abord envoyer puis enregistrer...

[Oliv-]

J'ai essayé de nouveau mon code de la méthode 2 il fonctionne correctement,

bien sûr tu dois avoir un dossier (windows) c:\temp

tu peux utiliser les points d'arrêt et le débogage pour y voir plus clair --> https://www.developpez.net/forums/bl.../debogage-vba/

[Oliv-]

oups j'ai oublié un truc important

tu dois soit redémarrer outlook en enregistrant le VBPAPROJECT
soit tu dois lancer la macro application_startup en cliquant dedans puis F5 , cela permet d'initialiser la variable colSentItems

et à chaque fois que tu vas faire un stop des macros ou après un plantage tu dois relancer cette macro.

[KASMINATOR]

J'ai repris la méthode 2 mais le problème c'est que la boite de dialogue ne s'ouvre pas pour proposer la localisation de l'enregistrement je reprends du début et je reviens vers toi.

Merci encore

[KASMINATOR]

Bonjour Oliv,

Effectivement j'ai repris les enchaînements du code et ça fonctionne parfaitement :

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?", vbQuestion + vbYesNo, "confirmation") = 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 = Repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Item.Subject, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 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

Par contre pour le nom du fichier j'aimerai bien que ça soit sous le format :

Date du jour format yymmdd puis mes initiales et l'object de l'e-mail

J'ai essayé de rajouter cela :

Code :

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

NomExport = Format(objCurrentMessage.CreationTime, "yymmdd") & "  " & "AKA" & "   " & objCurrentMessage.Subject

Mais ça n'abouti pas peut être à cause de la nomenclature colSentItems ?

Merci encore

[Oliv-]

SAlut,


Tu veux faire quoi avec cette partie de code ?

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
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

je te décompose la partie d'enregistrement

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
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
        repertoire = "C:\temp\"
 
'ç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 Sub

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