Bonjour à tou(te)s,
Le script ci-dessous copie les pièces jointes d'une boîte de réception (qui n'est pas celle par défaut) vers un dossier en omettant celles embarquées de type image, puis envoi un rapport des pièces jointes déplacées par mail avant de déplacer les mails en question vers un autre dossier de cette boîte.
Mon problème est le suivant, lorsque j'exécute manuellement le script ci dessous (Règles; Gérer les règles; Bouton "Exécuter une règle"; Bouton "Exécuter") tout fonctionne parfaitement. Mais en automatique, soit le script ne s'exécute pas à l'arrivée d'un nouveau message, ou il s"exécute s'il y a déjà un mail dans la boîte de réception (ce qui n'est pas toujours le cas), aussi il est difficile de trouver une logique du problème.
En espérant que vous pourrez m'aider car ce script doit (devrait) être en Prod prochainement.
Dans tous les cas, Merci d'avance de votre aide.
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
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199 Sub Execute(Mail As MailItem) Archive_Outlook_eMails_To_Backup_PST_Folder End Sub Sub Archive_Outlook_eMails_To_Backup_PST_Folder() Dim Items As Outlook.Items Dim Item As Object Set Items = GetFolderPath("toto@france.com\bzh").Items SaveAttachement report Dim FldBdr As Outlook.MAPIFolder Dim Fldbzh As folder Dim Fld As folder Dim Message As Outlook.MailItem Dim MailItem As Outlook.MailItem Dim MailsCount As Double, NumberOfDays As Double Dim ns As Outlook.NameSpace For Each Fld In Outlook.Session.Folders If Fld.Name Like "toto@france.com" Then Set Fldbzh = Fld.Folders("bzh") Set FldBdr = Fld.Folders("Boîte de réception") Exit For End If Next Fld Set ns = Application.GetNamespace("MAPI") NumberOfDays = 0 MailsCount = FldBdr.Items.Count While MailsCount > 0 If MailsCount >= 1 Then FldBdr.Items.Item(MailsCount).Move Fldbzh MailsCount = MailsCount - 1 Wend End Sub Sub SaveAttachement() Dim strFrom As String Dim strTo As String Dim strAttachment As String Dim bAttachment As Boolean Dim objMsg As MailItem Dim strFile As String Dim MailsCount As Double Set olApp = CreateObject("Outlook.Application") For Each Fld In Outlook.Session.Folders If Fld.Name Like "toto@france.com" Then Set Fldbzh = Fld.Folders("bzh") Set FldBdr = Fld.Folders("Boîte de réception") Exit For End If Next Fld Set ns = Application.GetNamespace("MAPI") Set NameSpace = olApp.GetNamespace("MAPI") Set objMsg = Application.CreateItem(olMailItem) MailsCount = FldBdr.Items.Count If MailsCount = O Then Exit Sub End If For Each Mail In FldBdr.Items For Each attachs In Mail.Attachments file = attachs.FileName If Right(attachs.FileName, 3) = "jpg" Then GoTo NextAttach ElseIf Right(attachs.FileName, 3) = "png" Then GoTo NextAttach ElseIf Right(attachs.FileName, 3) = "bmp" Then GoTo NextAttach End If attachs.SaveAsFile "\\Zebulon\Partage\Script\" & file i = i + 1 NextAttach: Next attachs Next Mail Set objMsg = Nothing End Sub Sub report() Dim strFrom As String Dim strTo As String Dim strAttachment As String Dim bAttachment As Boolean Dim objMsg As MailItem Set olApp = CreateObject("Outlook.Application") For Each Fld In Outlook.Session.Folders If Fld.Name Like "toto@france.com" Then Set Fldbzh = Fld.Folders("bzh") Set FldBdr = Fld.Folders("Boîte de réception") Exit For End If Next Fld Set ns = Application.GetNamespace("MAPI") Set NameSpace = olApp.GetNamespace("MAPI") Set objMsg = Application.CreateItem(olMailItem) MailsCount = FldBdr.Items.Count If MailsCount = O Then Exit Sub End If For Each Mail In FldBdr.Items For Each attachs In Mail.Attachments If Right(attachs.FileName, 3) = "jpg" Then GoTo NextAttach ElseIf Right(attachs.FileName, 3) = "png" Then GoTo NextAttach ElseIf Right(attachs.FileName, 3) = "bmp" Then GoTo NextAttach End If strAttachment = strAttachment & vbCrLf & attachs.DisplayName i = i + 1 NextAttach: Next attachs Next Mail strAttachment = strAttachment & vbNewLine objMsg.To = "alfred@france.com" objMsg.Body = "Pièce(s) jointe(s) déplacée(s) vers le dossier : " & "\\Zebulon\Partage\Script" & vbCrLf & vbCrLf & strAttachment objMsg.Subject = "Déplacement de pièces jointes" objMsg.Send Set objMsg = Nothing End Sub Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder Dim oFolder As Outlook.folder Dim FoldersArray As Variant Dim i As Integer On Error GoTo GetFolderPath_Error If Left(FolderPath, 2) = "\\" Then FolderPath = Right(FolderPath, Len(FolderPath) - 2) End If FoldersArray = Split(FolderPath, "\") Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) If Not oFolder Is Nothing Then For i = 1 To UBound(FoldersArray, 1) Dim SubFolders As Outlook.Folders Set SubFolders = oFolder.Folders Set oFolder = SubFolders.Item(FoldersArray(i)) If oFolder Is Nothing Then Set GetFolderPath = Nothing End If Next End If Set GetFolderPath = oFolder Exit Function GetFolderPath_Error: Set GetFolderPath = Nothing Exit Function End Function
Partager