Discussion :

[Repi17]

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 :

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

[Oliv-]

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 :

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
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 :

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

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/

[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.

[Oliv-]

Code :

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

SET SousDossier =fld.Folders("AAA")

as tu testé le code que j'ai corrigé ?

[Repi17]

Oui je l'ai testé

Mais j'ai une erreur avec cette ligne :

Code :

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

1
2
 
                    Set olmails = olmail

Je regarde demain matin pour l'accès au dossier direct sans boucle.

Merci encore !!

[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

[Repi17]

Bonjour, j'ai toujours l'erreur.

Code :

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

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

Pour :

Code :

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

    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 :/

[Oliv-]

il y a un olmail qui doit rester

Code :

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

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

[Repi17]

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

Code :

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

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

[Oliv-]

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

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

Code :

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

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

[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 ;à

[Oliv-]

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 :

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