Extraction fichiers ".msg" depuis emplacement réseau, pas depuis Outlook

**8Telegraphist8** · 11/04/2016, 15h46

Bonjour à tous,

Je cherche à adapter une Macro existante me permettant d'extraire et d'enregistrer la pièce jointe d'un mail, présent dans le dossier "Extraction" de mon Outlook 2010.
Cette Macro ne fait pas un simple enregistrement. Elle ouvre la pièce jointe puis va lire et copier le contenu de certaines cellules, colle ces contenus dans un fichier Excel puis s'en sert pour créer un nom de sauvegarde de la pièce jointe.

Je souhaite aujourd'hui l'adapter pour qu'au lieu d'extraire les messages présent dans le dossier Outlook "Extraction", qu'elle aille extraire des fichiers ".msg" présent dans un chemin classique sur le réseau.
La modif ne doit donc pas être énorme.

Dans Excel, j'utilise donc ce code au sein d'un fichier s'appelant "Extraction - Browser.xlsm":

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
 
 
Sub RetrieveMailFiles_Click()
 
Dim MonOutlook As Outlook.Application
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim Mypath As String
Dim i As Integer
Dim dtDate As Date
Dim sDate As String
Dim sName2 As String
Dim sName3 As String
Dim Inbox2 As MAPIFolder
Dim Inbox3 As MAPIFolder
Dim Td As Date
Dim Rd As Date
Dim Nd As String
Dim awb As Workbook
Dim aws As Worksheet
Set ns = GetNamespace("MAPI")
 
'le numéro est donné par la fonction "?ActiveExplorer.CurrentFolder.EntryID"
Set InboxFold = ns.GetFolderFromID("00000000CA5063795BBABA4E85B7BB93FA4923A901001D2C09AE1B48E742934DA9D063E6543B000000E6E19D0000")
 
Set awb = ActiveWorkbook
Set aws = awb.ActiveSheet
Dim d As String
 
Application.ScreenUpdating = False
 
    For Each Item In InboxFold.Items
        For Each Atmt In Item.Attachments
 
'-----------------------------------------------------------------------------------------------------------------------/ AAA /----------------------------------------
 
        If Item.UnRead = False And Right(Atmt.FileName, 3) = "xls" And Item.Body Like "*AAA*" Then
 
    'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\datefile.xls"
            Atmt.SaveAsFile FileName
            Workbooks.Open FileName
    'Copie de la cellule "A2" correspondant à la .............
            Range("A2").Select
            Selection.Copy
    'Collage du contenu de "A2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\datefile.xls"
            Workbooks.Open FileName
    'Copie de la cellule "E2" correspondant au nom du fond
            Range("E2").Select
            Selection.Copy
    'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
    'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
                sDate = aws.Range("D2").Value
                sName2 = aws.Range("D3").Value
                sName3 = aws.Range("B4").Value
 
            FileName = "H:\99. DWH\" & sDate & " - " & sName2 & " - " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Item.UnRead = False
 
'-----------------------------------------------------------------------------------------------------------------------/ BBB /----------------------------------------
 
                    ElseIf Item.UnRead = False And Right(Atmt.FileName, 3) = "xls" And Item.Body Like "*BBB*" Then
 
    'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\datefile.xls"
            Atmt.SaveAsFile FileName
            Workbooks.Open FileName
    'Copie de la cellule "A2" correspondant à la date de NAV
            Range("A2").Select
            Selection.Copy
    'Collage du contenu de "A2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\datefile.xls"
            Workbooks.Open FileName
    'Copie de la cellule "E2" correspondant au nom du fond
            Range("E2").Select
            Selection.Copy
    'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
    'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
                sDate = aws.Range("D2").Value
                sName3 = aws.Range("B4").Value
 
            FileName = "H:\99. DWH\" & sDate & " - " & "BBB" & " - " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Item.UnRead = False
 
        End If
 
    'Attachment suivant au sein du meme mail
       Next Atmt
 
    'Mail suivant
    Next Item
 
If InboxFold.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In XXX Inbox"
 
End If
 
End Sub

Je voudrais simplement remplacer le dossier Outlook "Extraction" par le chemin "H:\EEE\RRR\TTT\Incoming Mails\01.Classic Price.

Merci à vous

Fred

**Oliv-** · 11/04/2016, 16h44

Bonjour,
Voici pour ouvrir un fichier .msg

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
Public Sub OpenSharedMSG()
 
    Dim oNamespace As NameSpace
    Dim oSharedItem As MailItem
    Dim oFolder As Folder
 
    On Error GoTo ErrRoutine
 
    ' Get a reference to a NameSpace object.
    Set oNamespace = Application.GetNamespace("MAPI")
 
    ' Open .msg.
    Set oSharedItem = oNamespace.OpenSharedItem( _
        "C:\temp\Mise à jour CRM.msg")
 
    ' Pour l'enregistrer dans la boite de reception !
    oSharedItem.Save
 
    Set oFolder = oNamespace.GetDefaultFolder( _
        olFolderInbox)
    oFolder.Display
 
EndRoutine:
    On Error GoTo 0
    Set oSharedItem = Nothing
    Set oFolder = Nothing
    Set oNamespace = Nothing
Exit Sub
 
ErrRoutine:
    Select Case Err.Number
        Case 287 ' &H0000011F
            ' This error occurs if the code is run by an
            ' untrusted application, and the user chose not to
            ' allow access.
            MsgBox "Access to Outlook was denied by the user.", _
                vbOKOnly, _
                Err.Number & " - " & Err.Source
        Case -2147024894  ' &H80070002
            ' Occurs if the specified file or URL could not
            ' be found, or the file or URL cannot be
            ' processed by the OpenSharedItem method.
            MsgBox Err.Description, _
                vbOKOnly, _
                Err.Number & " - " & Err.Source
        Case -2147352567  ' &H80020009
            ' Occurs if the specified file or URL is not valid,
            ' or you attempt to use the Move method on
            ' an Outlook item that represents a shared item.
            MsgBox Err.Description, _
                vbOKOnly, _
                Err.Number & " - " & Err.Source
        Case Else
            ' Any other error that may occur.
            MsgBox Err.Description, _
                vbOKOnly, _
                Err.Number & " - " & Err.Source
    End Select
 
    GoTo EndRoutine
End Sub

**8Telegraphist8** · 11/04/2016, 17h06

Merci Oliv'

Je ne suis cependant pas sûr que cela réponde à ma question (sauf si je n'ai pas compris ton post).
Je ne cherche pas à ouvrir un fichier .msg en particulier mais à ouvrir tous les fichiers d'un dossier, les uns à la suite des autres, pour en extraire la pièce jointe :

1 - J'ai une liste de fichiers .msg dans "H:\Fichiers Mail" (par exemple)
2 - J'ouvre mon fichier Excel et je lance la Macro Excel d'extraction
3 - Les fichiers attachés s'enregistrent dans le dossier H:\Fichiers Mail\Pièces jointes (par exemple aussi)

La macro affichée fonctionne ainsi. Mon problème, c'est que cette macro point vers un sous-dossier Outlook grâce à :

Code :

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

1
2
 
Set InboxFold = ns.GetFolderFromID("00000000CA5063795BBABA4E85B7BB93FA4923A901001D2C09AE1B48E742934DA9D063E6543B000000E6E19D0000")

Je voudrais la faire pointer vers un emplacement réseau à la place. Du genre:

Code :

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

1
2
 
H:\Fichiers Mail\Pièces jointes

Fred

**Oliv-** · 11/04/2016, 17h44

Si j'ai bien compris tu as des fichiers .msg dans un dossier Windows et tu veux en extraire les PJ ?

donc il faut ouvrir chaque .msg ("avec outlook")

Code :

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

1
2
Set oSharedItem = oNamespace.OpenSharedItem( _
        "C:\temp\Mise à jour CRM.msg")

par contre tu ne l'enregistres pas sinon il retournerai dans OUTLOOK.

Code :

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

1
2
 ' Pour l'enregistrer dans la boite de reception !
    'oSharedItem.Save

puis tu lances ton traitement sur les PJ

Code :

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

1
2
3
 
For Each Atmt In oSharedItem.Attachments
...

ce qui donnerai :

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
Sub test_ProcessMsgInFolder()
'pour lancer le traitement
    Call ProcessMsgInFolder("c:\temp\", True)
 
End Sub
 
 
Sub TRAITEMENT_MSG(path)
    Set oSharedItem = oNamespace.OpenSharedItem(path)
For Each Atmt In oSharedItem.Attachments
...
 
Next Atmt
 
End Sub
 
'ca c'est la macro récursive.
Sub ProcessMsgInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
' adapté de Ole P Erlandsen
' necessite d'activer la reference Microsoft Scripting RunTime
    Static FSO As Object
    Dim oSourceFolder As Object
    Dim oSubFolder As Object
    Dim oFile As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = FSO.GetFolder(strFolderName)
 
    For Each oFile In oSourceFolder.Files
        If UCase(FSO.GetExtensionName(oFile.Name)) = "MSG" Then
            TRAITEMENT_MSG (oFile.path)
        End If
    Next oFile
 
    'For Each oSubFolder In oSourceFolder.SubFolders
    '' On peut mettre ici un traitement spécifique pour les dossiers
    'Next oSubFolder
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ProcessMsgInFolder oSubFolder.path, True
        Next oSubFolder
    End If
 
End Sub

**8Telegraphist8** · 11/04/2016, 19h08

Merci Oliv

Oui, c'est juste, c'est ce que je souhaites faire.
J'ai adapté la macro pour obtenir ceci :

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
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
 
Option Explicit
 
Sub test_ProcessMsgInFolder()
 
    Call ProcessMsgInFolder("H:\XXX\CCC\99. DWH\Incoming Mails\02.Nortfolio Details\", True)
 
End Sub
 
 
Sub ProcessMsgInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
 
' necessite d'activer la reference Microsoft Scripting RunTime
    Static FSO As Object
    Dim oSourceFolder As Object
    Dim oSubFolder As Object
    Dim oFile As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = FSO.GetFolder(strFolderName)
 
    For Each oFile In oSourceFolder.Files
        If UCase(FSO.GetExtensionName(oFile.Name)) = "MSG" Then
            TRAITEMENT_MSG (oFile.path)
        End If
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ProcessMsgInFolder oSubFolder.path, True
        Next oSubFolder
    End If
 
End Sub
 
 
Sub TRAITEMENT_MSG(path)
 
    Dim oNamespace As Namespace
    Dim oSharedItem As MailItem
    Dim oFolder As Folder
    Dim Atmt As Attachment
    Dim Item As Object
    Dim FileName As String
    Dim awb As Workbook
    Dim aws As Worksheet
    Dim Mypath As String
    Dim i As Integer
    Dim dtDate As Date
    Dim sDate As String
    Dim sName2 As String
    Dim sName3 As String
 
    Set oSharedItem = oNamespace.OpenSharedItem(path)
 
For Each Item In oSharedItem.Attachments
 
'-----------------------------------------------------------------------------------------------------------------------/ AAA /----------------------------------------
 
        If Item.UnRead = False And Right(Atmt.FileName, 3) = "csv" And Item.Body Like "*AAA*" Then
 
    'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            Atmt.SaveAsFile FileName
            Workbooks.Open FileName
 
            Columns("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                :=True
            Cells.EntireColumn.AutoFit
 
    'Copie de la cellule "C2" correspondant à la.....
            Range("C2").Select
            Selection.Copy
    'Collage du contenu de "C2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            'FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            'Workbooks.Open FileName
 
            Windows("Datefile").Activate
 
    'Copie de la cellule "E2" correspondant au ...........
            Range("B2").Select
            Selection.Copy
    'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
    'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
                sDate = aws.Range("D2").Value
                sName2 = aws.Range("D3").Value
                sName3 = aws.Range("B5").Value
 
            FileName = "H:\99. DWH\EXTRACTION\" & sDate & " - " & sName2 & " - " & " " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Workbooks.Open FileName
 
            Columns("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                :=True
            Cells.EntireColumn.AutoFit
 
            ActiveWorkbook.Save
            ActiveWorkbook.Close
 
            Item.UnRead = False
 
'-----------------------------------------------------------------------------------------------------------------------/ BBB /----------------------------------------
 
                    ElseIf Item.UnRead = False And Right(Atmt.FileName, 3) = "csv" And Item.Body Like "*BBB*" Then
 
    'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            Atmt.SaveAsFile FileName
            Workbooks.Open FileName
 
            Columns("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                :=True
            Cells.EntireColumn.AutoFit
 
    'Copie de la cellule "C2" correspondant à ............
            Range("C2").Select
            Selection.Copy
    'Collage du contenu de "A2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            'FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            'Workbooks.Open FileName
 
            Windows("Datefile").Activate
 
    'Copie de la cellule "E2" correspondant au ..........
            Range("B2").Select
            Selection.Copy
    'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
    'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
                sDate = aws.Range("D2").Value
                'sName2 = aws.Range("D3").Value
                sName3 = aws.Range("B5").Value
 
            FileName = "H:\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Centurion" & " - " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Workbooks.Open FileName
 
            Columns("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                :=True
            Cells.EntireColumn.AutoFit
 
            ActiveWorkbook.Save
            ActiveWorkbook.Close
            Item.UnRead = False
 
'-----------------------------------------------------------------------------------------------------------------------/ CCC /----------------------------------------
 
                    ElseIf Item.UnRead = False And Right(Atmt.FileName, 3) = "csv" And Item.Body Like "*CCC*" Then
 
    'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\EXTRACTION\datefile.xls"
            Atmt.SaveAsFile FileName
            Workbooks.Open FileName
 
            Columns("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                :=True
            Cells.EntireColumn.AutoFit
 
    'Copie de la cellule "A2" correspondant à ...
            Range("C2").Select
            Selection.Copy
    'Collage du contenu de "A2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            Workbooks.Open FileName
    'Copie de la cellule "E2" correspondant au ....
            Range("B2").Select
            Selection.Copy
    'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
    'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
    'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
                sDate = aws.Range("D2").Value
                'sName2 = "EFEFCE"
                sName3 = aws.Range("B5").Value
 
            FileName = "H:\99. DWH\EXTRACTION\" & sDate & " - " & "CCC" & " - " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Workbooks.Open FileName
 
            Columns("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                :=True
            Cells.EntireColumn.AutoFit
 
            ActiveWorkbook.Save
            ActiveWorkbook.Close
 
            Item.UnRead = False
 
'-----------------------------------------------------------------------------------------------------------------------/ DDD /----------------------------------------
 
'-----------------------------------------------------------------------------------------------------------------------/ EEE /----------------------------------------
 
'-----------------------------------------------------------------------------------------------------------------------/ FIN DU CODE /----------------------------------------
        End If
 
    'Attachment suivant au sein du meme mail
 
Next Atmt
 
    'Mail suivant
Next Item
 
'Kill FileName
 
If oSharedItem.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In RTZT Inbox"
 
End If
 
End Sub

Mais le code plante. Il y a un souci entre Atmt et Item et dans le For Each. Le code peut parfois aller jusqu'à la fin en mode pas à pas mais le plus souvent il bug sur :

Code :

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

1
2
 
    Set oSharedItem = oNamespace.OpenSharedItem(path)

Tu as une idée ?

Merci

Pour un accès plus simple voici la version sans la partie médiane

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
 
Option Explicit
 
Sub test_ProcessMsgInFolder()
 
    Call ProcessMsgInFolder("H:\99. DWH\Incoming Mails\02.Norttolio Details\", True)
 
End Sub
 
 
Sub ProcessMsgInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
 
' necessite d'activer la reference Microsoft Scripting RunTime
    Static FSO As Object
    Dim oSourceFolder As Object
    Dim oSubFolder As Object
    Dim oFile As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = FSO.GetFolder(strFolderName)
 
    For Each oFile In oSourceFolder.Files
        If UCase(FSO.GetExtensionName(oFile.Name)) = "MSG" Then
            TRAITEMENT_MSG (oFile.path)
        End If
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ProcessMsgInFolder oSubFolder.path, True
        Next oSubFolder
    End If
 
End Sub
 
 
Sub TRAITEMENT_MSG(path)
 
    Dim oNamespace As Namespace
    Dim oSharedItem As MailItem
    Dim oFolder As Folder
    Dim Atmt As Attachment
    Dim Item As Object
    Dim FileName As String
    Dim awb As Workbook
    Dim aws As Worksheet
    Dim Mypath As String
    Dim i As Integer
    Dim dtDate As Date
    Dim sDate As String
    Dim sName2 As String
    Dim sName3 As String
 
    Set oSharedItem = oNamespace.OpenSharedItem(path)
 
For Each Item In oSharedItem.Attachments
 
'---------------------------------------------------------------------------------------------------------------------------------------------------------------
       If
 
       ElseIf
 
       End If
'---------------------------------------------------------------------------------------------------------------------------------------------------------------
 
    'Mail suivant
    Next Item
 
'Kill FileName
If oSharedItem.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In EFEVCE Inbox"
 
End If
 
End Sub

**Oliv-** · 11/04/2016, 19h43

Tu as effectivement un problème

par exemple

Code :

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

1
2
3
4
5
6
7
    Set oSharedItem = oNamespace.OpenSharedItem(path)
 
For Each Item In oSharedItem.Attachments
 
'-----------------------------------------------------------------------------------------------------------------------/ AAA /----------------------------------------
 
        If Item.UnRead = False And Right(Atmt.FileName, 3) = "csv" And Item.Body Like "*AAA*" Then

oSharedItem = un item provenant du .msg soit à priori un Email

item est donc un attachment (une pièce jointe) de oSharedItem

et là tu mélanges tout

If Item.UnRead = False --> item serait un Email

And Right(Atmt.FileName, 3) ---> Atmt un attachment

tu devrais avoir en ligne 55

Code :

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

For Each Atmt  In oSharedItem.Attachments

Sinon tu peux simplement renommer

Set oSharedItem = oNamespace.OpenSharedItem(path)
en
Set Item = oNamespace.OpenSharedItem(path)

**8Telegraphist8** · 12/04/2016, 12h24

Bonjour Oliv'

C'est juste. Merci bien. Mais le code bloque toujours. J'ai essayé :

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
 
Option Explicit
 
Sub test_ProcessMsgInFolder()
 
    Call ProcessMsgInFolder("H:\BSI ManCo\Control Function\99. DWH\Incoming Mails\02.Portfolio Details\", True)
 
End Sub
 
 
Sub ProcessMsgInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
 
' necessite d'activer la reference Microsoft Scripting RunTime
    Static FSO As Object
    Dim oSourceFolder As Object
    Dim oSubFolder As Object
    Dim oFile As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = FSO.GetFolder(strFolderName)
 
    For Each oFile In oSourceFolder.Files
        If UCase(FSO.GetExtensionName(oFile.Name)) = "MSG" Then
            TRAITEMENT_MSG (oFile.path)
        End If
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ProcessMsgInFolder oSubFolder.path, True
        Next oSubFolder
    End If
 
End Sub
 
 
Sub TRAITEMENT_MSG(path)
 
    Dim oNamespace As Namespace
    Dim oSharedItem As MailItem
    Dim oFolder As Folder
    Dim Atmt As Attachment
    Dim Item As Object
    Dim FileName As String
    Dim awb As Workbook
    Dim aws As Worksheet
    Dim Mypath As String
    Dim i As Integer
    Dim dtDate As Date
    Dim sDate As String
    Dim sName2 As String
    Dim sName3 As String
 
    Set Item = oNamespace.OpenSharedItem(path)
 
For Each Item In oSharedItem.Attachments
 
'---------------------------------------------------------------------------------------------------------------------------------------------------------------
       If Item.UnRead = False And Right(Atmt.FileName, 3) = "csv" And Item.Body Like "*XXX*" Then
 
       ElseIf
 
       End If
'---------------------------------------------------------------------------------------------------------------------------------------------------------------
 
    'Mail suivant
    Next Item
 
'Kill FileName
If oSharedItem.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In EFEVCE Inbox"
 
End If
 
End Sub

et ceci :

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
 
 
Option Explicit
 
Sub test_ProcessMsgInFolder()
 
    Call ProcessMsgInFolder("H:\99. DWH\Incoming Mails\02.Norttolio Details\", True)
 
End Sub
 
 
Sub ProcessMsgInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
 
' necessite d'activer la reference Microsoft Scripting RunTime
    Static FSO As Object
    Dim oSourceFolder As Object
    Dim oSubFolder As Object
    Dim oFile As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = FSO.GetFolder(strFolderName)
 
    For Each oFile In oSourceFolder.Files
        If UCase(FSO.GetExtensionName(oFile.Name)) = "MSG" Then
            TRAITEMENT_MSG (oFile.path)
        End If
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ProcessMsgInFolder oSubFolder.path, True
        Next oSubFolder
    End If
 
End Sub
 
 
Sub TRAITEMENT_MSG(path)
 
    Dim oNamespace As Namespace
    Dim oSharedItem As MailItem
    Dim oFolder As Folder
    Dim Atmt As Attachment
    Dim Item As Object
    Dim FileName As String
    Dim awb As Workbook
    Dim aws As Worksheet
    Dim Mypath As String
    Dim i As Integer
    Dim dtDate As Date
    Dim sDate As String
    Dim sName2 As String
    Dim sName3 As String
 
    Set oSharedItem = oNamespace.OpenSharedItem(path)
 
For Each Atmt In oSharedItem.Attachments
 
'---------------------------------------------------------------------------------------------------------------------------------------------------------------
       If oSharedItem.UnRead = False And Right(Atmt.FileName, 3) = "csv" And Item.Body Like "*AAA*" Then
 
       ElseIf
 
       End If
'---------------------------------------------------------------------------------------------------------------------------------------------------------------
 
    Next Atmt
 
'Kill FileName
If oSharedItem.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In EFEVCE Inbox"
 
End If
 
End Sub

Mais ca bloque. Parfois sur la ligne en gras (Set Item = oNamespace.OpenSharedItem(path)) et parfois sur le "Next" à la fin du code...

**Oliv-** · 12/04/2016, 23h20

BONSOIR,

Le premier code est toujours faux

ligne 55 : For Each Item In oSharedItem.Attachments

si tu renommes oSharedItem en Item il faut le faire partout !

à partir de ton second code voici mes modifications à tester
j'ai également simplifié une partie du code Excel.

tu declares

Dim awb As Workbook
Dim aws As Worksheet

mais tu ne les instancies pas ? =(par exemple set aws =activeworkbook)

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
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
 
 
 
 
Option Explicit
 
Sub test_ProcessMsgInFolder()
 
    Call ProcessMsgInFolder("H:\99. DWH\Incoming Mails\02.Norttolio Details\", True)
 
End Sub
 
 
Sub ProcessMsgInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
 
' necessite d'activer la reference Microsoft Scripting RunTime
    Static FSO As Object
    Dim oSourceFolder As Object
    Dim oSubFolder As Object
    Dim oFile As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = FSO.GetFolder(strFolderName)
 
    For Each oFile In oSourceFolder.Files
        If UCase(FSO.GetExtensionName(oFile.Name)) = "MSG" Then
            TRAITEMENT_MSG (oFile.path)
        End If
    Next oFile
 
    If bIncludeSubfolders Then
        For Each oSubFolder In oSourceFolder.SubFolders
            ProcessMsgInFolder oSubFolder.path, True
        Next oSubFolder
    End If
 
End Sub
 
 
Sub TRAITEMENT_MSG(path)
 
    Dim oNamespace As Namespace
    Dim oSharedItem As MailItem
    Dim oFolder As Folder
    Dim Atmt As Attachment
    Dim Item As Object
    Dim FileName As String
    Dim awb As Workbook
    Dim aws As Worksheet
    Dim Mypath As String
    Dim i As Integer
    Dim dtDate As Date
    Dim sDate As String
    Dim sName2 As String
    Dim sName3 As String
 
 
    Dim ws As Worksheet
 
    Set oSharedItem = oNamespace.OpenSharedItem(path)
 
    For Each Atmt In oSharedItem.Attachments
 
        '---------------------------------------------------------------------------------------------------------------------------------------------------------------
        If oSharedItem.UnRead = False And Right(Atmt.FileName, 3) = "csv" And oSharedItem.Body Like "*AAA*" Then
 
            'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            Atmt.SaveAsFile FileName
            Set ws = Workbooks.Open(FileName)
 
            ws.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                            Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                                                                                                     :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                                                                                                             Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                                                                                                                                                                                                        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                                                                                                                                                                                                                                                                                               (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                                                                                                                                                                                                    Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                                                                                                                                                                                                                                                                                        33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                                                                                                                                                                                                                                                                                                                                                       :=True
            ws.Cells.EntireColumn.AutoFit
 
            'Copie de la cellule "C2" correspondant à la.....
            ws.Range("C2").Copy
            'Collage du contenu de "C2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Paste
            Application.CutCopyMode = False
            'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            'FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            'Workbooks.Open FileName
 
            ws.Parent.Activate
 
            'Copie de la cellule "E2" correspondant au ...........
            ws.Range("B2").Copy
            'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Paste
            Application.CutCopyMode = False
            'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
            'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
            sDate = aws.Range("D2").Value
            sName2 = aws.Range("D3").Value
            sName3 = aws.Range("B5").Value
 
            FileName = "H:\99. DWH\EXTRACTION\" & sDate & " - " & sName2 & " - " & " " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Workbooks.Open FileName
 
            Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                         Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                                                                                                  :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                                                                                                          Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                                                                                                                                                                                                     ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                                                                                                                                                                                                                                                                                            (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                                                                                                                                                                                                 Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                                                                                                                                                                                                                                                                                     33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                                                                                                                                                                                                                                                                                                                                                    :=True
            Cells.EntireColumn.AutoFit
 
            ActiveWorkbook.Save
            ActiveWorkbook.Close
 
            Item.UnRead = False
 
            '-----------------------------------------------------------------------------------------------------------------------/ BBB /----------------------------------------
 
        ElseIf oSharedItem.UnRead = False And Right(Atmt.FileName, 3) = "csv" And oSharedItem.Body Like "*BBB*" Then
 
            'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            Atmt.SaveAsFile FileName
            Workbooks.Open FileName
 
            Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                         Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                                                                                                  :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                                                                                                          Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                                                                                                                                                                                                     ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                                                                                                                                                                                                                                                                                            (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                                                                                                                                                                                                 Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                                                                                                                                                                                                                                                                                     33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                                                                                                                                                                                                                                                                                                                                                    :=True
            Cells.EntireColumn.AutoFit
 
            'Copie de la cellule "C2" correspondant à ............
            Range("C2").Copy
            'Collage du contenu de "A2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Paste
            Application.CutCopyMode = False
            'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            'FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            'Workbooks.Open FileName
 
            Windows("Datefile").Activate
 
            'Copie de la cellule "E2" correspondant au ..........
            Range("B2").Copy
            'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Paste
            Application.CutCopyMode = False
            'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
            'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
            sDate = aws.Range("D2").Value
            'sName2 = aws.Range("D3").Value
            sName3 = aws.Range("B5").Value
 
            FileName = "H:\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Centurion" & " - " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Workbooks.Open FileName
 
            Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                         Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                                                                                                  :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                                                                                                          Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                                                                                                                                                                                                     ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                                                                                                                                                                                                                                                                                            (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                                                                                                                                                                                                 Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                                                                                                                                                                                                                                                                                     33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                                                                                                                                                                                                                                                                                                                                                    :=True
            Cells.EntireColumn.AutoFit
 
            ActiveWorkbook.Save
            ActiveWorkbook.Close
            Item.UnRead = False
 
            '-----------------------------------------------------------------------------------------------------------------------/ CCC /----------------------------------------
 
        ElseIf oSharedItem.UnRead = False And Right(Atmt.FileName, 3) = "csv" And oSharedItem.Body Like "*CCC*" Then
 
            'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\EXTRACTION\datefile.xls"
            Atmt.SaveAsFile FileName
            Workbooks.Open FileName
 
            Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                         Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                                                                                                  :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                                                                                                          Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                                                                                                                                                                                                     ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                                                                                                                                                                                                                                                                                            (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                                                                                                                                                                                                 Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                                                                                                                                                                                                                                                                                     33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                                                                                                                                                                                                                                                                                                                                                    :=True
            Cells.EntireColumn.AutoFit
 
            'Copie de la cellule "A2" correspondant à ...
            Range("C2").Copy
            'Collage du contenu de "A2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B2").Paste
            Application.CutCopyMode = False
            'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
            FileName = "H:\99. DWH\EXTRACTION\datefile.xls"
            Workbooks.Open FileName
            'Copie de la cellule "E2" correspondant au ....
            Range("B2").Copy
            'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
            Windows("Extraction - Browser.xlsm").Activate
            Range("B3").Paste
            Application.CutCopyMode = False
            'Fermeture du fichier temporaire "datefile..xls"
            Workbooks("datefile.xls").Close
            Kill FileName
 
            'Création du fichier final
            Windows("Extraction - Browser.xlsm").Activate
            ActiveWorkbook.Save
 
            sDate = aws.Range("D2").Value
            'sName2 = "EFEFCE"
            sName3 = aws.Range("B5").Value
 
            FileName = "H:\99. DWH\EXTRACTION\" & sDate & " - " & "CCC" & " - " & sName3 & ".xls"
            Atmt.SaveAsFile FileName
 
            Workbooks.Open FileName
 
            Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                         Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                                                                                                  :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                                                                                                          Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                                                                                                                                                                                                     ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                                                                                                                                                                                                                                                                                            (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
                                                                                                                                                                                                 Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
                                                                                                                                                                                                                                                                                     33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1)), TrailingMinusNumbers _
                                                                                                                                                                                                                                                                                                                                                    :=True
            Cells.EntireColumn.AutoFit
 
            ActiveWorkbook.Save
            ActiveWorkbook.Close
 
            Item.UnRead = False
 
            '-----------------------------------------------------------------------------------------------------------------------/ DDD /----------------------------------------
 
            '-----------------------------------------------------------------------------------------------------------------------/ EEE /----------------------------------------
 
            '-----------------------------------------------------------------------------------------------------------------------/ FIN DU CODE /----------------------------------------
        End If
 
        'Attachment suivant au sein du meme mail
        '---------------------------------------------------------------------------------------------------------------------------------------------------------------
 
    Next Atmt
 
    'Kill FileName
 
 
End Sub

**Oliv-** · 12/04/2016, 23h32

c'est toi là ?

**8Telegraphist8** · 18/04/2016, 10h46

Envoyé par Oliv-

c'est toi là ?

Oui

**8Telegraphist8** · 19/04/2016, 19h37

Hello Oliv.

Ca ne fonctionne pas. Je suis désolé.
En réalité je ne pensais pas que cela serait si difficile à réaliser puisque la Macro fonctionne bien à partir du fichier Excel.
En gros, j'ouvre le fichier Excel "Extraction - Browser", qui comporte deux macros :

- RetrieveMailFiles_Click
- RetrieveMailFilesCSV_Click

Ces deux macros vont regarder dans un sous-dossier Outlook appelé "Extraction" les mails lus, et extraire les pièces jointes, en utilisant des données contenues dans des cellules de ces pièces jointes pour construire le nom du fichier sauvegardé.

Je cherchais simplement à effectuer automatiquement ce processus à l'arrivée d'un type de mail, grâce à une règle.

Je peux t'envoyer le code que j'utilise si tu veux.

Fred

**Oliv-** · 20/04/2016, 10h17

SAlut Fred,

Tu n'expliques pas ce qui ne marche pas ! Oui avec le code complet ce serait plus simple

**8Telegraphist8** · 20/04/2016, 11h17

Hello Oliv'

Je t'ai envoyé le code par email.
Si tu as le temps de jeter un œil dessus, c'est vrai qu'il vaut mieux l'avoir en entier

Fred

**Oliv-** · 20/04/2016, 13h01

Est ce que c'est toujours le même sujet ?

Au début tu parles de Fichiers .msg présents sur un partage réseau et que tu veux traiter.

et là

tu as des macros qui parcourent une bal OUTLOOK pour enregistrer les PJ Excel ou CSV selon un libellé contenu dans le corps de l'Email ?

en plus tu as des blocs If elseif qui font la même chose

il n'y a que cette partie qui change

Code :

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

1
2
3
4
5
  sDate = aws.Range("D2").Value
                'sName2 = "BSI Multinvest SICAV"
                sName3 = aws.Range("B4").Value
 
                FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Centurion" & " - " & sName3 & ".xls"

qu"y a t'il dans tes formules ?

aws.Range("D2").Value '(2015.10.20)
aws.Range("D3").Value '(BSI-Multinvest - Asian/Bond)
aws.Range("B4").Value

que désigne awb ? ="Extraction - Browser.xlsm" ?

**Oliv-** · 20/04/2016, 13h20

Essaye ce code en replacement de RetrieveMailFiles_Click

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
Sub RetrieveMailFiles_Click()
 
    Dim MonOutlook As Outlook.Application
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim Mypath As String
    Dim i As Integer
    Dim dtDate As Date
    Dim sDate As String
    Dim sName2 As String
    Dim sName3 As String
    Dim Inbox2 As MAPIFolder
    Dim Inbox3 As MAPIFolder
    Dim Td As Date
    Dim Rd As Date
    Dim Nd As String
    Dim awb As Workbook
    Dim aws As Worksheet
    Set ns = GetNamespace("MAPI")
 
    Set InboxFold = ns.GetFolderFromID("00000000CA5063795BBABA4E85B7BB93FA4923A901001D2C09AE1B48E742934DA9D063E6543B000000E6E19D0000")
 
    Set awb = ThisWorkbook
    Set aws = awb.ActiveSheet
    Dim d As String
 
    Application.ScreenUpdating = False
 
    For Each Item In InboxFold.Items
        For Each Atmt In Item.Attachments
 
            '-----------------------------------------------------------------------------------------------------------------------/ MULTINVEST /----------------------------------------
 
            If Item.UnRead = False And Right(Atmt.FileName, 3) = "xls" Then
 
                'Création d'un fichier temporaire "datefile" correspondant à la pièce jointe
                FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\datefile.xls"
                Atmt.SaveAsFile FileName
                Workbooks.Open FileName
                'Copie de la cellule "A2" correspondant à la date de NAV
                Range("A2").Copy aws.Range("B2")
                'Collage du contenu de "A2" dans la cellule "B2" du fichier "Extraction - Browser.xlsm"
 
                'Ouverture du fichier temporaire "datefile" correspondant à la pièce jointe
                Workbooks.Open FileName
                'Copie de la cellule "E2" correspondant au nom du fond
                Range("E2").Copy aws.Range("B3")
                'Collage du contenu de "E2" dans la cellule "B3" du fichier "Extraction - Browser.xlsm"
 
                'Fermeture du fichier temporaire "datefile..xls"
                Workbooks("datefile.xls").Close
                Kill FileName
 
                'Création du fichier final
                Windows("Extraction - Browser.xlsm").Activate
                ActiveWorkbook.Save
                sDate = aws.Range("D2").Value          '(2015.10.20)
 
                If Item.Body Like "*Multinvest*" Then
 
                    sName2 = aws.Range("D3").Value      '(BSI-Multinvest - Asian/Bond)
                    sName3 = aws.Range("B4").Value      '(Classic Price)
 
                    FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & sName2 & " - " & sName3 & ".xls"
 
                    '--------------------------------------------------/ MULTI CHALLENGE SICAV - Centurion /----------------------------------------
                ElseIf Item.Body Like "*MULTI CHALLENGE SICAV - Centurion*" Then
 
                    'sName2 = "BSI Multinvest SICAV"
                    sName3 = aws.Range("B4").Value
 
                    FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Centurion" & " - " & sName3 & ".xls"
 
                    '---------------------------------------------------/ MULTI CHALLENGE SICAV - Globes /----------------------------------------
                ElseIf Item.Body Like "*MULTI CHALLENGE SICAV - Globes*" Then
                    'sName2 = "BSI Multinvest SICAV"
                    sName3 = aws.Range("B4").Value
 
                    FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Globes Portfolio" & " - " & sName3 & ".xls"
 
 
                    '----------------------------------------------------/ MULTI CHALLENGE SICAV - Global Inflation Shield /----------------------------------------
                ElseIf Item.Body Like "*Multi Challenge Sicav - Global*" Then
 
                    'sName2 = "BSI Multinvest SICAV"
                    sName3 = aws.Range("B4").Value
 
                    FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Global Inflation Shield" & " - " & sName3 & ".xls"
 
 
                    '-----------------------------------------------------------------------------------------------------------------------/ MULTI CHALLENGE SICAV - Global Inflation Shield /----------------------------------------
                ElseIf Item.Body Like "*Multi Challenge Sicav - Global*" Then
                    'sName2 = "BSI Multinvest SICAV"
                    sName3 = aws.Range("B4").Value
 
                    FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Global Inflation Shield" & " - " & sName3 & ".xls"
                    '-----------------------------------------------------------------------------------------------------------------------/ HEREFORD /----------------------------------------
 
                ElseIf Item.Body Like "*Hereford Funds*" Then
                    sName2 = aws.Range("D3").Value      '(BSI-Multinvest - Asian/Bond)
                    sName3 = aws.Range("B4").Value      '(Classic Price)
 
                    FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & sName2 & " " & sName3 & ".xls"
 
 
                    '-----------------------------------------------------------------------------------------------------------------------/ MULTI CHALLENGE SICAV - Digamma /----------------------------------------
                ElseIf Item.Body Like "*MULTI CHALLENGE SICAV - Digamma*" Then
                    'sName2 = "BSI Multinvest SICAV"
                    sName3 = aws.Range("B4").Value
 
                    FileName = "H:\BSI ManCo\Control Function\99. DWH\EXTRACTION\" & sDate & " - " & "MULTI CHALLENGE SICAV - Digamma" & " - " & sName3 & ".xls"
 
                End If
 
                Atmt.SaveAsFile FileName
 
                Item.UnRead = False
 
 
 
 
            End If
 
            'Attachment suivant au sein du meme mail
        Next Atmt
        'Mail suivant
    Next Item
    'Kill FileName
    If InboxFold.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In Multichallenge Globes Inbox"
 
    End If
 
End Sub

**8Telegraphist8** · 20/04/2016, 13h24

Hello Oliv,

Il y a deux choses :

Point 1

J'utilise Outlook VBA pour qu'un script puisse être exécuté lors du déroulement d'une règle. Ce script permet d'effectuer un enregistrement du mail arrivant sur le réseau.

- Un type de mail arrive
- La règle correspondante à ce type de mail s'exécute et range le mail dans un dossier Outlook
- La règle correspondante exécute le script qui enregistre le .msg sur le réseau

----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Point 2

J'utilise un fichier Excel "Extraction - Browser" dans lequel deux macros, permettent de réaliser une extraction des pièces jointes dans des mails contenus dans un sous-dossier "Extraction" de Outlook.

Le problème c'est que mes mails sont déja sur le réseau puisque "Point 1" s'est réalisé avant. Je dois donc recopier les messages du réseau vers Outlook avant d'executer les macros.

-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Je souhaite donc "fusionner" ces deux macros de manière à ce que celles de "Point 1" s'exécute automatiquement.

Je dois adapter le code (celui envoyé en MP) pour le coller à une régle Outlook dans le but que la procédure se déroule ainsi :

- Un type de mail arrive
- La règle correspondante à ce type de mail s'exécute et range le mail dans un dossier Outlook
- La règle correspondante exécute le script qui enregistre le .msg sur le réseau
- La règle correspondante extrait la pièce jointe et l'enregistre sur le réseau

Est-ce plus clair pour toi ?

Merci

Fred

**Oliv-** · 20/04/2016, 13h27

et ta règle actuelle une fois l'Email enregistré en .msg elle le supprime de OUTLOOK ?

**8Telegraphist8** · 20/04/2016, 15h26

Non non, elle le garde dans un sous-dossier.

Pourquoi ?

**Oliv-** · 20/04/2016, 15h36

Pourquoi veux tu alors extraire la pj du fichier .msg plutot que du Mail se trouvant dans OUtlook ?

**8Telegraphist8** · 20/04/2016, 15h58

Parce que je sauvegarde le mail pour des raisons de sécurité mais la pièce jointe pour des besoins d'exploitation de ses données internes (cellules Excel).
Toutes mes pièces jointes sont des fichiers Excel (.xls et .csv que je transforme en .xlsx). J'en reçois une grosse quantité tous les jours, et une fois par semaine, je les réunis grâce à une autre macro pour en faire un gros fichier uploadé dans Access puis dans d'autres fichiers Excel

Fred

Extraction fichiers ".msg" depuis emplacement réseau, pas depuis Outlook [OL-2010]

VBA Outlook

Discussions similaires

Partager

Partager