Bonjour,

La macro ci-dessous permets d'extraire les PJ des e-mail pour les sauvegarder.

Ce que je n'arrive pas à faire, c'est d'extraire la PJ et de le sauvegarder avec la données indiqués en H22 de PJ puis suivi du nom du fichier.

Exemple :
- Nom de la PJ attachée dans le mail = fichier.xls
- Donnée en cellule H22 de la PJ = 50048842

Sauvegarde la PJ comme cela => 50048842-fichier.xls

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
 
Option Explicit
Option Compare Text
 
 
Sub Extraire_PJ()
    Extraction "Dossier1", "a@test.com"
 
End Sub
 
 
Sub Extraction(NomDossier As String, Expediteur As String)
 
'Déclaration des objets
    Dim olApp As Outlook.Application
    Dim olSpace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim OLinbox As Outlook.MAPIFolder
    Dim olmail As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment
    Dim MonBody As String, MonNum As String
    Dim y As Integer, x As Integer
    Dim nom As Variant
 
    Dim osa As Shell
    Dim xrDec As Variant
    Dim nfZip As Variant
 
'Instance des Objets
    Set olApp = New Outlook.Application
    Set olSpace = olApp.GetNamespace("MAPI")
    Set OLinbox = olSpace.GetDefaultFolder(olFolderInbox)
    Set olFolder = OLinbox.Folders(NomDossier)
 
 
For Each olmail In olFolder.Items
        If olmail.SenderEmailAddress = Expediteur And _
            Not olmail.Attachments.Count = 0 Then
 
            For y = 1 To olmail.Attachments.Count
                 Set pceJointe = olmail.Attachments(y)
                 x = x + 1
 
'Données en celulle H22
ligne = 22
colonne = 8
feuille= "feuil1"
monum = ExecuteExcel4Macro _
   ("'" & "" & "\[" & pceJointe & "]" & feuille & "'!R" & ligne & "C" & colonne & "")
 
' Recherche de PJ : ".xlsx", ".xlsm", ".xls", ".zip"
        If Right(pceJointe, 5) = ".xlsx" Or Right(pceJointe, 4) = ".xls" Or Right(pceJointe, 4) = ".zip" Or Right(pceJointe, 5) = ".xlsm" Then
            GoTo 1
        Else
            GoTo 2
        End If
 
' Extrait les PJ : ".xlsx", ".xlsm", ".xls"
                If IsNumeric(MonNum) And Not Right(pceJointe, 4) = ".zip" Then
                MsgBox "OK! C'est un N° : " & MonNum
                pceJointe.SaveAsFile "C:\Documents\" & MonNum & "-" & pceJointe
                Set pceJointe = Nothing
            Next y
 
        End If
            Next olmail
 
End Sub

Merci de votre aide svp