Récuperer PJ puis suppr en fonction du sous dossier et d'emetteur du mail

Version imprimable

Bonjour,

En faisant des recherches sur le net, j'ai trouvé une macro que j'ai adapté à mon besoin.

Mais j'aimerais lui ajouter des fonctions...

Aujourd'hui, via VBA dans Excel, la macro va cherche les PJ dans un sous dossier nommé AAA dans Outlook, elle extrait les PJ et leurs donnent un numéro et un nom.

Voici le code :
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 Option Explicit '------------------------------------------------------------------------ 'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library '------------------------------------------------------------------------ Dim x As Integer Sub downloadPJ() Dim Ol As New outlook.Application Dim Ns As outlook.Namespace Dim Dossier As outlook.MAPIFolder Set Ns = Ol.GetNamespace("MAPI") Set Dossier = Ns.Folders(1) SearchFolders Dossier x = 0 End Sub Private Sub SearchFolders(ByVal fld As outlook.MAPIFolder) Dim y As Integer Dim olmail As Object Dim olmails As outlook.MailItem Dim pceJointe As outlook.Attachment Dim SousDossier As outlook.MAPIFolder For Each SousDossier In fld.Folders If SousDossier = "AAA" Then For Each olmail In SousDossier.Items MsgBox olmail.SenderEmailAddress If Not olmail.Attachments.Count = 0 Then If olmails.SenderEmailAddress = "test@test.com" Then y = 1 Set pceJointe = olmails.Attachments(y) x = x + 1 pceJointe.SaveAsFile "d:\TRAITEMENT\" & x & "_" & pceJointe 'olmail.Delete a créer Set pceJointe = Nothing End If End If Next olmail End If SearchFolders SousDossier Next SousDossier End Sub
Je souhaiterais si possible que la macro verifier l'adresse mail mais le code ne fonctionne pas.. Pourtant en message box, il trouve bien l'adresse mail..
Je souhaiterais aussi qu'elle supprime le mail après avoir extrait la PJ. J'ai réussi sur une autre macro mais je n'arrive pas à mixer les deux.

Enfin, je cherche une cherche une function qui permet de compter le nombre de mail dans le sous dossier AAA
En gros, si le nombre de mail ne correspond pas, la macro attend l'arrivée des mails (pour palier au problème réseau) ^^

Merci d'avance, si vous avez des idées pour m'orienter :)

Merci

Repi17

Bonjour,

TOn Test de l'Email ne fonctionne pas sans doute parce que tu as mélangé olmails et olmail

Pourquoi parcours tu tous les DOSSIERS (For Each SousDossier In fld.Folders) ?

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
Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
 
Dim x As Integer
Sub downloadPJ()
    Dim Ol As New outlook.Application
    Dim Ns As outlook.Namespace
    Dim Dossier As outlook.MAPIFolder
 
    Set Ns = Ol.GetNamespace("MAPI")
    Set Dossier = Ns.Folders(1)
 
    SearchFolders Dossier
    x = 0
End Sub
 
Private Sub SearchFolders(ByVal fld As Outlook.MAPIFolder)
    Dim y As Integer
    Dim olmail As Object
    Dim olmails As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment
    Dim SousDossier As Outlook.MAPIFolder
 
    For Each SousDossier In fld.Folders
        If SousDossier = "AAA" Then
        MsgBox SousDossier.Items.Count, vbInformation, "nombre de items dans AAA"
 
 
 
            For Each olmail In SousDossier.Items
                If olmail.Class = olmail Then
                    Set olmails = olmail
                    MsgBox olmails.SenderEmailAddress
                    If Not olmails.Attachments.Count = 0 Then
                        If olmails.SenderEmailAddress = "test@test.com" Then
                            y = 1
                            Set pceJointe = olmails.Attachments(y)
                            x = x + 1
                            pceJointe.SaveAsFile "d:\TRAITEMENT\" & x & "_" & pceJointe
                            'olmail.Delete a créer
                            Set pceJointe = Nothing
                        End If
                    End If
                Next olmail
 
 
 
 
            End If
            SearchFolders SousDossier
        Next SousDossier
    End Sub

Par contre si tu veux supprimer les Mails il faut procéder autrement que par "FOR EACH"

tu dois faire une boucle comme cela

Code:

1
2
3
4
5
6
7
8
9
10
For i = SousDossier.Items.Count to 1 step-1
 
 If  SousDossier.Items(i).Class = olmail Then
                    Set olmails = SousDossier.Items(i)
'....
 
olmails.delete
End if
 
Next i

regarde ici : traitement recursif
https://www.developpez.net/forums/bl...sous-dossiers/

et là export de pj
https://www.developpez.net/forums/bl...yperlien-mail/

12/09/2017, 14h48
Repi17

Merci pour la réponse

Le .count c'est nickel !!

Je boucle pour trouver le bon dossier car je ne sais pas comment faire pour chercher directement le bon. Je vois bien la fonction dans le lien que tu m'as envoyé mais je sais pas l'appliquer.

Oui j'avais une faute de frappe, mais même sans, ça ne change rien.

Merci

Je regarde les liens que tu m'as envoyé.

Pour la fonction suppression, je vais la mettre dans une autre partie de la macro.
12/09/2017, 15h04
Oliv-

Code:

SET SousDossier =fld.Folders("AAA")

as tu testé le code que j'ai corrigé ?
12/09/2017, 21h35
Repi17
Oui je l'ai testé

Mais j'ai une erreur avec cette ligne :
Code:

1 2 Set olmails = olmail
Je regarde demain matin pour l'accès au dossier direct sans boucle.

Merci encore !!
13/09/2017, 11h33
Oliv-

Bonjour,
c'est parce que c'est une constante de OULTOOK

Const olMail = 43 (&H2B)
Membre de Outlook.OlObjectClass

Remplace olMail par oMail ou objMail ou autre chose
13/09/2017, 12h09
Repi17
Bonjour, j'ai toujours l'erreur.
Code:

1 2 If omail.Class = omail Then Set olmails = omail
Pour :

Code:

Set SousDossier = fld.Folders("AAA")

ça fonctionne, si je place mon sous dossier en dehors de ma boite de réception, mais il ne trouve pas mon sous dossier AAA dans le sous dossier "Boite de réception".
Je ne sais pas si je suis bien comprehensible :/

il y a un olmail qui doit rester

Code:

1
2
If omail.Class = olmail Then
                    Set omails = omail

J'ai essayé ça, ça fonctionne bien :

Code:

1
2
3
4
5
6
7
                Set omails = SousDossier.Items(i)
 
                    MsgBox omails.Sender.GetExchangeUser.PrimarySmtpAddress
 
                    If Not omails.Attachments.Count = 0 Then
 
                        If omails.Sender.GetExchangeUser.PrimarySmtpAddress = "test@test.com" Then

Merci !!!

Si tu as une idée pour le sous-dossier qui se trouve dans "Boite de réception" sans boucle :)

alors çà c'est le cas où ton email arrive de ton domaine exchange

sinon de l'extérieur c'est bien senderemailaddress
Code:

1 2 3 4 5 6 7 8 Private Function Get_sender_SMTP(oItem As Outlook.MailItem) As String Dim oEU As Outlook.ExchangeUser On Error Resume Next Set oEU = oItem.Sender.GetExchangeUser Get_sender_SMTP = oEU.PrimarySmtpAddress If Get_sender_SMTP = "" Then Get_sender_SMTP = oItem.SenderEmailAddress End Function
attention à la casse quand même avec ton "=" (voir OPTION COMPARE TEXT ou STRCOMP)

pour le dossier j'ai répondu là https://www.developpez.net/forums/d1...l/#post9606845

14/09/2017, 09h12
Repi17

Bonjour,

C'est noté pour le exchange, je ne connais pas encore l'adresse mail qui m'enverra les données.

J'ai vu pour ta réponse : https://www.developpez.net/forums/d1...l/#post9606845

Mais c'est ce que j'expliquais dans mon precedent post. Cela fonctionne mais je dois placer le sous dossier AAA sous mon adresse mail dans outlook et on pas sous mon dossier boîte de reception.

Exemple : (dans la colonne gauche de outlook) :

Favoris

Boîte de réception
Elements envoyés
Elements supprimés
____________________________________
test@test.com

AAA
Boîte de reception

Sous dossier 1
Sous dossier 2
Sous dossier 3
Sous dossier 4

Idealement, je souhaiterai placé le sous dossier AAA au meme niveau que les autres sous dossiers mais ça reste que du detail.

Si tu as une idée..

Merci pour l'ensemble ;à

Salut,
donc si c'est ta boite principale et que AAA est au même niveau que BOITE DE RECEPTION

J'ai pas testé mais ce code doit fonctionner

ps tu lances directement dans OUTLOOK ou via EXCEL ?

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
 Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
 
Dim x As Integer
Sub downloadPJ()
 
    Dim OL As Outlook.Application
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
    Dim Ns As Outlook.NameSpace
    Dim Dossier As Outlook.MAPIFolder
 
    Set Ns = OL.GetNamespace("MAPI")
    Set Dossier = Ns.GetDefaultFolder(olFolderInbox).Parent
    Set SousDossier = Dossier.Folders("AAA")
    MsgBox Dossier    'pour tester
    SearchFolders Dossier
    x = 0
End Sub
 
 
 
 
Private Sub SearchFolders(ByVal SousDossier As Outlook.MAPIFolder)
    Dim y As Integer, i
    Dim oMail As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment
 
 
    MsgBox SousDossier.Items.Count, vbInformation, "nombre de items dans AAA"
 
    For i = SousDossier.Items.Count To 1 Step -1
 
        If SousDossier.Items(i).Class = olmail Then
            Set oMail = SousDossier.Items(i)
            MsgBox oMail.SenderEmailAddress
            If Not oMail.Attachments.Count = 0 Then
                If StrComp(Get_sender_SMTP(oMail), "test@test.com", vbTextCompare) = 0 Then
                    y = 1
                    Set pceJointe = oMail.Attachments(y)
                    x = x + 1
                    pceJointe.SaveAsFile "d:\TRAITEMENT\" & x & "_" & pceJointe
                    Set pceJointe = Nothing
                    oMails.Delete
                End If
            End If
        End If
    Next i
End Sub
 
 
Private Function Get_sender_SMTP(oItem As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = oItem.Sender.GetExchangeUser
 
    Get_sender_SMTP = oEU.PrimarySmtpAddress
    If Get_sender_SMTP = "" Then Get_sender_SMTP = oItem.SenderEmailAddress
End Function