Traiter automatiquement pièces jointes

Version imprimable

bonjour,

j'aimerai traiter de manière automatique ou semi-automatique des mails qui contiennent plusieurs mails en pièce jointe : chaque jour, je reçois 1 mail avec 26 messages (.msg) joints.

Jusqu'à présent, j'arrive à lister le numéro et la taille de chaque message joint mais je n'arrive pas à accéder au contenu (Body) des messages joints.
Voici mon code actuel (merci developpez.com) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Private Sub Application_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Selection As Selection)
 
    Dim objButton As CommandBarButton
    Dim intButtonIndex As Integer
    Dim intCounter As Integer
 
    'Test si 1 seul mail est sélectionné
    If Selection.Count = 1 Then
        'Test si la sélection correspond à un E-mail
        If Selection.Item(1).Class = olMail Then
            Set objButton = CommandBar.Controls.Add(msoControlButton, , , , True)
            With objButton
                .Style = msoButtonIconAndCaption
                .Caption = "Infos sur le Mail"
                .FaceId = 463
                .OnAction = "Projet 1.ThisOutlookSession.InfosMail"
            End With
        End If
    End If
 
End Sub

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
Sub InfosMail()
'---------------------------------------------------------------------------------------
' Procédure : InfosMail
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 25/04/2008
' Détail    : Macro permettant de parcourir les pièces jointes d'une sélection et affiche
'             le nom et la taille de chaque pièce jointe dans une boîte de message
'---------------------------------------------------------------------------------------
'
'Déclarations des objets et variables
    Dim objItem As Object
    Dim objAttachment As Attachments
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer
    Dim MonTexte As String
 
    'Instancie les objets
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
 
    'Boucle permettant de parcourir les pièces jointes une à une
    For Each myItem In myOlSel
        'instancie l'objet avec la pièce jointe en cours
        Set objAttachment = myItem.Attachments
        'Si pièce jointe affichage
        If objAttachment.Count > 0 Then
            For i = 1 To objAttachment.Count
                MonTexte = MonTexte & "PJ" & tmp & i & " > " & MEF_Octet(objAttachment(i).Size) & vbCr
            Next i
        End If
    Next
 
    MsgBox MonTexte
 
    'Vide des objets pour libération de la mémoire
    Set objItem = Nothing
    Set objAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub

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
Public Function MEF_Octet(lgValeur As Long) As String
'---------------------------------------------------------------------------------------
' Procédure : MEF_Octet
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 25/04/2008
' Détail    : Fonction permettant un affichage en octet, kilo, mega ou giga selon valeur passée en paramètre
'---------------------------------------------------------------------------------------
'
'test si la valeur correspond à l'octet
    If (lgValeur / 1024 > 1) Then
        lgValeur = lgValeur / 1024
        'test si la valeur correspond au kilo
        If (lgValeur / 1024 > 1) Then
            lgValeur = lgValeur / 1024
            'test si la valeur correspond au méga
            If (lgValeur / 1024 > 1) Then
                lgValeur = lgValeur / 1024
                'test si la valeur correspond au giga
                If (lgValeur / 1024 > 1) Then
                    lgValeur = lgValeur / 1024
                Else
                    MEF_Octet = CStr(lgValeur) & " Go"    'charge la valeur convertie en string dans la variable
                End If
            Else
                MEF_Octet = CStr(lgValeur) & " Mo"  'charge la valeur convertie en string dans la variable
            End If
        Else
            MEF_Octet = CStr(lgValeur) & " Ko"    'charge la valeur convertie en string dans la variable
        End If
    Else
        MEF_Octet = CStr(lgValeur) & " Oct"    'charge la valeur convertie en string dans la variable
    End If
 
End Function

Mon objectif est donc :
- soit d'enregistrer au format TXT l'ensemble des .msg joints (et non pas le message parent) par exemple dans C:/Tmp
- soit de concaténer l'ensemble des contenus des .msg joints et d'enregistrer le résultat par exemple dans C:/Tmp

Merci d'avance pour vos lumières

SAlut,
En adaptant ce code tu devrais y arriver

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
'---------------------------------------------------------------------------------------
' Procedure : RenvoiLaPJdeTouteLaSelection
' Author    : Oliv'
' Date      : 26/11/2008
' Purpose   :
'---------------------------------------------------------------------------------------
'
Sub RenvoiLaPJdeTouteLaSelection()
    Dim MonOutlook As Outlook.Application
    Dim Mail   As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    For Each LeMail In LesMails
        If LeMail.subject Like "Notification  d'état  de  remise  (échec)" Then
 
            Dim pj As Attachment
            For Each pj In LeMail.Attachments
                If Right(UCase(pj.FileName), 4) = ".MSG" Then
                    LeFichier = "c:\temp\ziptemp\" & pj.FileName
                    pj.SaveAsFile (LeFichier)
                    Ouverture_msg (LeFichier)
                    Kill LeFichier
                End If
            Next pj
            LeMail.Delete
        End If
    Next LeMail
    Set LesMails = Nothing
    MsgBox "Opération terminée"
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Ouverture_msg
' Author    : Oliv'
' Date       : 26/11/2008
' Purpose   : Ouvrir un .msg d'un dossier de l'explorateur
'---------------------------------------------------------------------------------------
'
Sub Ouverture_msg(LeFichier As String)
    Set myolApp = Outlook.Application
    shellcommande = """C:\Program Files\Microsoft Office\OFFICE11\OUTLOOK.EXE"" /f """ & LeFichier & """"
    RetVal = Shell(shellcommande, 1)
    DoEvents
    Set myItem = myolApp.ActiveInspector.CurrentItem
    'MsgBox "Sujet: " & myItem.subject & vbCr & "reçu le : " & myItem.ReceivedTime & vbCr & "A: " & myItem.To & vbCr & "Email Exp: " & myItem.SenderEmailAddress & vbCr & "PJ: " & myItem.Attachments.Count
    myItem.Categories = "Idées"
    myItem.Send
    On Error Resume Next
    myItem.Close 0
    On Error GoTo 0
End Sub

04/12/2012, 13h10
Riri80

Bonjour,

merci pour ta réponse.
Effectivement, j'arrive à enregistrer les pièces jointes dans un répertoire.
Cependant, j'aimerai enregistrer chaque pièce jointe au format texte et non .msg qui est binaire dans mon cas.
Via l'interface, lorsque j'ouvre un des mails joints, je peux faire "enregistrer sous" et ça me l'enregistre au format .txt.
Il ne manque plus qu'à l'automatiser ...

Merci d'avance.
04/12/2012, 13h24
Oliv-
Si tes pj sont en .msg tu dois les enregistrer sur le disque puis les ouvrir
Changes dans ouverture_msg
Code:

1 2 myItem.Categories = "Idées" myItem.Send
Par ton code de sauvegarde

Ouf ça marche !

Voici mon code final :

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
Private Sub Application_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Selection As Selection)
 
    Dim objButton As CommandBarButton
    Dim intButtonIndex As Integer
    Dim intCounter As Integer
 
    'Test si 1 seul mail est sélectionné
    If Selection.Count = 1 Then
        'Test si la sélection correspond à un E-mail
        If Selection.Item(1).Class = olMail Then
            Set objButton = CommandBar.Controls.Add(msoControlButton, , , , True)
            With objButton
                .Style = msoButtonIconAndCaption
                .Caption = "Extraire les rapports"
                .FaceId = 463
                .OnAction = "Projet 1.ThisOutlookSession.RenvoiLaPJdeTouteLaSelection"
            End With
        End If
    End If
 
End Sub
 
Sub RenvoiLaPJdeTouteLaSelection()
 
    Dim MonOutlook As Outlook.Application
    Dim Mail   As Object
    Dim LeMail As Outlook.MailItem
    Dim LeMail2 As Outlook.MailItem
    Dim LesMails As Object
    Dim Rapport As String
    Dim pj As Attachment
    Dim i As Integer
 
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
 
    For Each LeMail In LesMails
 
        i = 1
 
        For Each pj In LeMail.Attachments
            If Right(UCase(pj.FileName), 4) = ".MSG" Then
 
                LeFichier = "C:\tmp\fichier_" & i & ".msg"
                pj.SaveAsFile LeFichier
                Set LeMail2 = MonOutlook.CreateItemFromTemplate("C:\tmp\fichier_" & i & ".msg")
                Rapport = Rapport & LeMail2.Body
                Kill "C:\tmp\fichier_" & i & ".msg"
 
                i = i + 1
                Set LeMail2 = Nothing
                Set pj = Nothing
 
            End If
        Next pj
 
    Next LeMail
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile("C:\tmp\rapport.txt", True)
    a.writeline (Rapport)
    a.Close
    Set fs = Nothing
    Set a = Nothing
 
    Set LesMails = Nothing
    MsgBox "Opération terminée"
 
End Sub

Merci beaucoup pour ton aide.