Sauvegarde d'un mail [Résolu]

[myrddin772]

Bonjour à tous !

Je développe une macr sous Ooutlook (une première pour moi) qui doit numéroter l'e-mail dans son sujet, le déplacer dans un dossier adéquat et le sauvegarder sur un disque en proposant la boîte de dialogue "enregistrer sous" au moment de l'envoi.
La macro est donc placée dans Application_ItemSend de ThisOutlookSession. Elle numérote et déplace l'e-mail sans soucis, par contre pas moyen de trouver le moyen d'affihcer la boîte de dialogue... Quelqu'un saurait-il m'aider ?

Merci d'avance

[Oliv-]

Bonjour,
Voici un exemple :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub ShowDialog()
    Dim objInsp
    Dim colCB
    Dim objCBB
    On Error Resume Next
    Set objInsp = ActiveInspector
    Set colCB = objInsp.CommandBars
    'Set objCBB = colCB.FindControl(, 30007) 'outil
    'Set objCBB = colCB.FindControl(, 31145) 'outil
    'Set objCBB = colCB.FindControl(, 1757) 'new mail
 Set objCBB = colCB.FindControl(, 748) 'enregistrer  sous
 
 
    If Not objCBB Is Nothing Then
        objCBB.Execute
    End If
 End Sub

[myrddin772]

Merci Oliv-

J'ai essayé. Malheureusement ça n'affiche rien...
Un autre problème se pose : en forçant l'enregistrement dans ItemSend, l'e-mail est bien sauvegardé (au format msg) mais il affiche "Ce message n'a pas été envoyé".

Je suppose que ceci est dû au fait que l'enregistrement soit effectué avant l'envoi "physique" de l'e-mail. Mais alors comment faire pour enregistrer correctement l'e-mail envoyé après son envoi ?

[myrddin772]

Bonjour !

En cherchant hier un peu sur le net j'ai trouver le code suivant :

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
Public Function GetFolderPathWithWord() As String
    Dim objWord As Word.Application
    Dim dlg As Office.FileDialog
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim objOL As Outlook.Application
    Dim objOLWindow As Object
 
    On Error Resume Next
 
    ' Récupération de la fenêtre Outlook active
    Set objOL = CreateObject("Outlook.Application")
    Set objOLWindow = objOL.ActiveWindow
 
    ' Démarrage de Word si nécessaire
    Set objWord = GetObject(, "Word.Application")
    If objWord Is Nothing Then
        Set objWord = CreateObject("Word.Application")
    End If
    If Not objWord Is Nothing Then
        ' Récupération des dimensions de la fenêtre Word
        lngWidth = objWord.Width
        lngHeight = objWord.Height
        ' Réduction de la fenêtre
        objWord.Width = 0
        objWord.Height = 0
        ' Passage vers Word
        objWord.Activate
 
        ' Affichage de la boîte de dialogue et gestion des choix de l'utilisateur
        Set dlg = objWord.FileDialog(msoFileDialogFolderPicker)
        With dlg
            .InitialView = msoFileDialogViewList
            .InitialFileName = "P:\"
            If .Show = -1 Then
                GetFolderPathWithWord = dlg.SelectedItems(1) & "\"
            Else
                GetFolderPathWithWord = "canceled"
            End If
        End With
    Else
        GetFolderPathWithWord = "Could not open Word"
    End If
 
    ' Si aucun document Word n'est ouvert, on quitte
    If objWord.Documents.Count = 0 Then
        objWord.Quit
    Else
        ' sinon on lui redonne les dimensions initiales
        objWord.Width = lngWidth
        objWord.Height = lngHeight
    End If
 
    ' et on retourne sur Outlook
    objOLWindow.Activate
 
    ' On annule les références aux objets
    Set objWord = Nothing
    Set dlg = Nothing
    Set objOL = Nothing
    Set objOLWindow = Nothing
End Function

Ok ! Ce n'est pas des plus "joli" mais au moins j'arrive à choisir un dossier pour enregistrer le chemin d'accès dans un coin.

Si quelqu'un a une méthode plus simple et plus propre, je suis preneur. en attendant mon problème de sélection vient de se résoudre.
En tous cas, Oliv-, MERCI de ton aide !

[Oliv-]

Salut,
En fait le mail avant et après l'envoi sont 2 choses différentes. il faut attendre l'événement MAPIFolder.Items.ItemAdd sur le dossier où sera classé le mail pour continuer le traitement et donc "enregistrer sous" le msg.

voici un exemple à mettre dans ThisOutlookSession:

Code :

1
2
3
4
5
6
7
8
9
 
Private Sub Application_Startup()
'pour evenement itemadd
   Dim NS As Outlook.NameSpace
   Set NS = Application.GetNamespace("MAPI")
   Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).Items
   Set NS = Nothing
 'fin section
end sub

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
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:\"
        Strname = Repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Item.Subject, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160)
        Enrg = MsgBox(Item.Subject & vbCr & "sous : " & vbCr & Strname & ".msg", vbYesNoCancel, "Enregistrer sur le disque ce mail ?")
        If Enrg = vbYes Then
            ' 1ère façon sans boite de dialogue on connait l'endroit où enregistrer
            'Repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
            Item.SaveAs Strname & ".msg", OlSaveAsType.olMSG
 
        ElseIf Enrg = vbNo Then
        ' 2ème méthode on ouvre une boite de dialogue
         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 If
End Sub