Discussion :

[Yochi37]

Bonjour,
J'ai un répertoire sous Windows (et non dans ma boite outlook) dans lequel j'enregistre des mails qui contiennent des pièces jointes.
Pouvez-vous me donner le code VBA pour ouvrir ces fichiers et extraire les pièces jointes dans un autre dossier ?
D'avance merci de votre aide.

[Jean-Philippe André]

Salut,

quels ont été tes essais jusqu'à présent ?

Sur quelle étape rencontres tu des soucis ?
- la boucle sur les fichiers
- l'ouverture et extraction des PJ
- l'enregistrement des PJ

[Oliv-]

Bonsoir,
Il faut utiliser OpenSharedItem, ensuite pour extraire les pj c'est comme un mail classique.

voici un exemple,

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
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")
 
 
 
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

[Yochi37]

Bonsoir,

@Oliv- : J'ai essayé ton code mais il ne fonctionne pas. J'ai modifié le lien "C:..." et ai positionné les bibliothèques Outlook. Mais le message renvoyé est le suivant : "Erreur d'exécution 438 : Propriété ou méthode non gérée par cet objet".
Il plante sur Set oNamespace = Application.GetNamespace("MAPI")

@Jean Philipp André : Je débute sur VBA Outlook. Je ne pense pas avoir de problème sur la boucle. Par contre ce que je voudrais faire et que n'arrive pas à faire, c'est d'ouvrir le mail que j'ai au préalable enregistré sur dans un répertoire windows, ouvrir la pièce jointe (ou l'enregistrer dans un dossier Windows). J'ai essayé la fonction "OpenSharedItem" mais sans succès.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Public Sub OpenSharedMSG()
 
    Dim oNamespace As Namespace
    Dim oSharedItem As MailItem
    Dim oFolder As Folder
 
    ' Get a reference to a NameSpace object.
    Set oNamespace = Application.GetNamespace("MAPI")
 
    ' Open .msg.
    Set oSharedItem = oNamespace.OpenSharedItem(ThisWorkbook.Path & "\Fichiers_Sources\TEST.msg")
 
End Sub

Merci de votre aide.

[Oliv-]

dans quel programme lances tu ce code ?

[Yochi37]

Je le lance via Excel 2010.

[Oliv-]

Salut,

C'est très important !

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
Public Sub OpenSharedMSG()
 
Dim OL As Object
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    Dim oNamespace As OBJECT 'namespace
    Dim oSharedItem As object 'MailItem
    Dim oFolder As Object 'Folder
 
    On Error GoTo ErrRoutine
 
    ' Get a reference to a NameSpace object.
    Set oNamespace = OL.GetNamespace("MAPI")
 
    ' Open .msg.
    Set oSharedItem = oNamespace.OpenSharedItem( _
        "C:\temp\Mise à jour CRM.msg")
 
For each pj in osharedItem.attachments
pj.saveas &c:\temp \"& pj.filename
Next pj
 
 
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

[Yochi37]

Merci de ton aide !
J'ai adapté un peu et ça fonctionne comme cela.
Je n'ai plus qu'à faire la boucle sur les fichiers, je devrais m'en sortir à présent.
Encore merci.

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
 
Public Sub OpenSharedMSG()
 
    Dim OL As Object
    Set OL = CreateObject("outlook.application")
 
    Dim oNamespace As Object
    Set oNamespace = OL.GetNamespace("MAPI")
 
    Dim Mail As Object
    Set Mail = oNamespace.OpenSharedItem(ThisWorkbook.Path & "\Fichiers_Sources\TEST.msg")
 
    Date_Mail = Format(Mail.ReceivedTime, "YYYYMMDD HHMMSS")
 
    For Each PJ In Mail.Attachments
        If Right(PJ.Filename, 5) = ".xlsx" Then
            PJ.SaveAsFile ThisWorkbook.Path & "\Fichiers_Sources\" & Left(PJ.Filename, Len(PJ.Filename) - 5) & Date_Mail & ".xlsx"
        End If
    Next PJ
 
End Sub