Extraire Pièces jointe (*.xls et *.zip uniquement) d'outlook

**roidurif** · 22/12/2009, 13h54

Bonjour,

La macro suivante permet d'extraire tout type de pièces jointes d'outlook vers un dossier défini, en ajoutant au prefixe du "nom du fichier", le numéro à 8 chiffres (500xxxxx) se trouvant dans le corps du texte e-mail.

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
 
Sub Extraction(NomDossier As String, Expediteur As String)
    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
 
    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
 
 
        ' Recherche de 500 dans le corps du message
        MonBody = olmail.Body
 
        On Error Resume Next
        MonNum = Mid(MonBody, InStr(1, MonBody, " 500") + 1, 8)
        On Error GoTo 0
                If MonNum = Empty Then
            MsgBox "Numéro 5008 non trouvé"
        Else
                If IsNumeric(MonNum) Then
                    MsgBox "OK! C'est un N° : " & MonNum
                pceJointe.SaveAsFile "C:\Documents\" & MonNum & "-" & pceJointe
                Set pceJointe = Nothing
 
                Else
                    MsgBox "KO! Ce n'est pas un N° :" & MonNum
                End If
        End If
 
            Next y
        End If
 
 
    Next olmail
 
End Sub

Deux problématiques s'ouvrent devant moi :

Lorsque je recois des e-mail avec des pièces jointes, en signature il y a des images par exemple ou des documents zipé.

1) Comment extraire uniquement les PJ au format *.xls ou (*.xls-Zipé), (Pas les images .jpg par exemple, ou autres formats) ?

2) Comment dois-je adapter cette macro ci-dessous qui me permet d'extraire les documents zipés avec la macro du dessus (En gardant le principe de mettre en prefixe du nom du fichier le numéro à 8 chiffres (500xxxxx) se trouvant dans le corps du texte e-mail) ?

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
 
Sub Extraire_fichier_zip()
 
'Ajouter la référence "Microsoft Shell Controls and Automation"
Dim osa As Shell
Dim xrDec As Variant
Dim nfZip As Variant
 
xrDec = "C:\Documents\" 'Dossier de destination
nfZip = "C:\Documents\Fichier.zip" 'Fichier zipé à extraire
 
Set osa = New Shell
osa.NameSpace(xrDec).CopyHere osa.NameSpace(nfZip).Items
Set osa = Nothing
 
End Sub

J'espere avoir été claire et je vous remercie par avance.

Cordialement

roidurif

**Jean-Philippe André** · 22/12/2009, 14h41

salut,
tu peux faire un test sur les 4 caractères de droite sur l'intitulé du fichier.
Si tu tombes sur ".xls" ou ".zip", tu traites, sinon tu passes au suivant

**roidurif** · 22/12/2009, 16h00

Re,

Comment dois-je m y prendre?

Merci de l'aide

**Jean-Philippe André** · 22/12/2009, 16h26

La propriété FileName devrait faire l'affaire avec ta variable pceJointe

**roidurif** · 22/12/2009, 16h36

J'ai fait cela, mais je bloque car j'ai un message qui me dit "Next sans For"

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 
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      
 
  If Right(pceJointe, 5) <> ".xlsx" Or Right(pceJointe, 4) <> ".zip" Then
        Next y
        End If

merci de l'aide

**Jean-Philippe André** · 22/12/2009, 16h38

oui, toute boucle If then doit se terminer par un End If

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
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      
 
  If Right(pceJointe, 5) <> ".xlsx" Or Right(pceJointe, 4) <> ".zip" Then
  End If
        Next y
        End If

**roidurif** · 22/12/2009, 16h45

Merci,, je crois le fait que Next Y est de fois, ca plante, "erreur de compilation".

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
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      
 
  If Right(pceJointe, 5) <> ".xlsx" Or Right(pceJointe, 4) <> ".zip" Then
  End If
        Next y
        End If

        ' Recherche de 500 dans le corps du message
        MonBody = olmail.Body

        On Error Resume Next
        MonNum = Mid(MonBody, InStr(1, MonBody, " 500") + 1, 8)
        On Error GoTo 0
                If MonNum = Empty Then
            MsgBox "Numéro 5008 non trouvé"
        Else
                If IsNumeric(MonNum) Then
                    MsgBox "OK! C'est un N° : " & MonNum
                pceJointe.SaveAsFile "C:\" & MonNum & "-" & pceJointe
                Set pceJointe = Nothing
                
                Else
                    MsgBox "KO! Ce n'est pas un N° :" & MonNum
                End If
        End If
         
            Next y
        End If

Merci encore

**roidurif** · 23/12/2009, 10h14

Bonjour,

J'avance petit à petit, mais je bloque cette fois-ci à la décompréssion d'un fichier zipé, pour ensuite rajouté au nom du fichier le numéro trouvé dans corps du texte.

Je vous remercie 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
 
Sub Extraction(NomDossier As String, Expediteur As String)
    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
 
    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
 
 
' 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
 
1:
 
' Recherche de 500 dans le corps du message
        MonBody = olmail.Body
 
        On Error Resume Next
        MonNum = Mid(MonBody, InStr(1, MonBody, " 500") + 1, 8)
        On Error GoTo 0
                If MonNum = Empty Then
            MsgBox "Numéro 500 non trouvé"
        Else
 
' 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:\" & MonNum & "-" & pceJointe
                Set pceJointe = Nothing
 
                Else
' Extrait les PJ : ".zip"
                If IsNumeric(MonNum) And Right(pceJointe, 4) = ".zip" Then
                MsgBox "OK! C'est un N° : " & MonNum
                xrDec = "C:\" 'fichier destination
                nfZip = "C:\" & pceJointe 'fichier source
 
                Set osa = New Shell
                osa.NameSpace(xrDec).CopyHere osa.NameSpace(nfZip).Items
                Set osa = Nothing
 
' En cas d'absence du numéro "500"
 
                Else
                    MsgBox "KO! Ce n'est pas un N° :" & MonNum
                End If
        End If
        End If
 
2:
            Next y
        End If
 
 
    Next olmail
 
 
End Sub

Extraire Pièces jointe (.xls et .zip uniquement) d'outlook

Macros et VBA Excel

Discussions similaires

Partager

Partager