Script de sauvegarde sous Outlook

[benhamidaa]

j'ai des dossiers pour chaque contact important, et avec une règle je classe mes messages, au niveau des messages j'ai des fichiers que je veux les enregistres d'une maniére automatique dans un répertoire de mon disque (exemple c:\jean\fichier1.doc), Comment faire, je ne connais absolument rien sur les Script VBA.


Aider Moi Merci

[Dolphy35]

Salut,

je crois que tu ne va pas avoir le choix, tu devras passer par le VBA.

Comment sauvegarder les pièces jointes d'un message sans ouvrir ce message ?

Dolphy

[benhamidaa]

C'est bon mais comment rendre la macro automatique

[Dolphy35]

salut,

avec la procédure : Application_NewMail () dans le module : ThisOutlookSession.
Tu as un exemple dans la

Comment peut-on exécuter une action en VBA lors de l'arrivée d'un nouveau mail ?

Dolphy

[benhamidaa]

Salut,

Je veux seulement les pièces joint je suis novice, tu m'excuse.
comment placer les deux macros

Merci.

[Dolphy35]

Salut,

c'est pas grave

voici le code à mettre dans le module ThisOutlookSession.

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
Private Sub Application_NewMail()
 
    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer
 
    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination", "Save Attachments", "C:\temp\")
 
    On Error Resume Next
 
    'Actions sur les objets sélectionnés
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
 
    'boucle
    For Each myItem In myOlSel
        Set myAttachments = myItem.Attachments
        If myAttachments.Count > 0 Then
            'Ajoute une remarque dans le corps du message
            myItem.Body = myItem.Body & vbCrLf & _
                "pièce jointe enlevée:" & vbCrLf
 
            'for all attachments do...
            For i = 1 To myAttachments.Count
 
                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
 
            Next i
 
            'Enlève les pièces jointes du message
            While myAttachments.Count > 0
 
                myAttachments(1).Delete
 
            Wend
 
            'Sauvegarde le message sans ses pièces jointes
            myItem.Save
        End If
 
    Next
 
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub

dans le code le chemin de destination sera C:\temp\

Dolphy

[Oliv-]

SAlut,

Quelle version as tu benhamidaa ?

à partir de 2003 préférer l'évenement NewMailEx pour ne pas parcourir tout le dossier ou l'éxécution d'un script sur une règle.

"Cet événement se produit lors de la réception d'un ou plusieurs éléments dans la Boîte de réception. Cet événement transmet une liste d'identificateurs d'entrée de tous les éléments reçus dans la Boîte de réception depuis le dernier déclenchement de l'événement. "
Attention le code de Dolphy35 efface les pj de tes mails !!

Dolphy35 voici une autre façon de faire cela en contrôlant les doublons des PJ et si la PJ est une PJ incorporée dans le mail (comme les images) ou non.

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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
Copiez ce code dans un module. Puis créez une règle à l'arrivée d'un nouveau message selon les conditions que vous souhaitez et choississez comme action Exécuter un script + arrêter de traiter plus de règles.
 
Dans cet exemple le répertoire C:\TEMP\pj doit exister.
 
Vous devez aussi référencer Microsoft CDO 1.21 Library dans VBE.
 
 
 
Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
 
' ***olivier CATTEAU***
 
' 23 avril 2007
 
Dim olNS As Outlook.NameSpace 
Dim MyMail As Outlook.MailItem
 
Dim expediteur 
Set olNS = Application.GetNamespace("MAPI") 
Set MyMail = olNS.GetItemFromID(strID.EntryID)
 
'MsgBox "nouveau message"
 
If MyMail.Attachments.Count > 0 Then
 
expediteur = MyMail.SenderEmailAddress
 
 
 
'on crée le répertoire où mettre les fichiers joints ##########################################################
 
'c:\temp\pj\ doit déjà exister !!!
 
Repertoire = "c:\temp\pj\" & expediteur & "\"
 
If Repertoire <> "" Then
 
If "" = Dir(Repertoire, vbDirectory) Then
 
MkDir Repertoire
 
End If
 
End If
 
 
 
'on traite les pj
 
Dim PJ, typeatt 
 
For Each PJ In MyMail.Attachments 
'vérification si c'est une PJ Embedded
 
typeatt = Isembedded(strID, PJ.index)
 
If typeatt = "" Then
 
If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then
 
MsgBox Repertoire & PJ.FileName & " existe !!"
 
'si existe copie vers le répertoire old
 
If "" = Dir(Repertoire & "old", vbDirectory) Then
 
MkDir Repertoire & "old"
 
End If
 
FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName
 
End If
 
PJ.SaveAsFile Repertoire & PJ.FileName
 
End If
 
Next PJ 
 
'drapeau vert
 
MyMail.FlagIcon = olGreenFlagIcon
 
'Marque lu
 
MyMail.UnRead = False
 
MyMail.Save
 
'on déplace le mail vers un sous dossier outlook
 
Dim myDestFolder As Outlook.MAPIFolder
 
Set myDestFolder = MyMail.Parent.Folders("test") 
MyMail.Move myDestFolder
 
End If 
 
Set MyMail = Nothing 
Set olNS = Nothing
 
Fin:
 
End Sub
 
 
 
' Function: Fields_Selector
 
' Purpose: View type of attachment
 
' olivier catteau fevrier 2006
 
Function Isembedded(ByVal strEntryID As String, attindex As Integer) As Variant
 
Dim oSession As MAPI.Session 
' CDO objects
 
Dim oMsg As MAPI.Message 
Dim oAttachs As MAPI.Attachments
 
Dim oAttach As MAPI.Attachment 
 
' initialize CDO session
 
On Error Resume Next
 
Set oSession = CreateObject("MAPI.Session") 
oSession.Logon "", "", False, False
 
 
 
' get the message created earlier
 
Set oMsg = oSession.GetMessage(strEntryID) 
' set properties of the attached graphic that make
 
' it embedded and give it an ID for use in an <IMG> tag
 
Set oAttachs = oMsg.Attachments 
Set oAttach = oAttachs.Item(attindex) 
Dim strCID As String
 
strCID = oAttach.Fields(&H3712001E)
 
Isembedded = strCID
 
Set oMsg = Nothing
 
oSession.Logoff
 
Set oSession = Nothing
 
 
 
End Function

Si tu trouves cela trop compliqué il y a des logiciels payant qui font cela.