Discussion :

[nonesofar]

Bonjour,

Je souhaite depuis excel, déplacer les emails dans un sous dossier spécifique en fonction du sujet de l'email.

Pour cela j'ai une petite macro qui fonctionne bien pour déplacer les emails.

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 copyItems()
  Dim myInbox As Outlook.Folder
  Dim myDestFolder As Outlook.Folder
  Dim myItems As Outlook.Items
  Dim myItem As Object
 
  Set myInbox = Session.PickFolder
  Set myDestFolder = Session.PickFolder
  Set myItems = myInbox.Items
    For i = myItems.Count To 1 Step -1
        'Debug.Print i
        If InStr(myItems(i).Subject, "test - Fichier de Collecte") > 0 Then
            myItems(i).Move myDestFolder
        End If
    Next
End Sub

Mais si j’écris

Code :

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

.copy

cela plante. J'ai vu sur des forums qu'il fallait copier d'abord puis déplacer ensuite mais je suis pas arrivé à faire un truc cohérent dans la boucle.

Si vous avez une idée d’évolution de mon code.

Bonne journée.

[parmi]

Bonjour,

Essaie comme ceci

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
Sub copyItems()
    Dim I As Long
    Dim myInbox As Outlook.Folder
    Dim myDestFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myItem As MailItem
    Dim Copie As MailItem
 
    Set myInbox = Session.PickFolder
    Set myDestFolder = Session.PickFolder
    Set myItems = myInbox.Items
    For I = myItems.Count To 1 Step -1
        'Debug.Print i
        If InStr(myItems(I).Subject, "Mail delivery") > 0 Then
            Set Copie = myItems(I).Copy
            Copie.Move myDestFolder
        End If
    Next
 
    Set myInbox = Nothing
    Set myDestFolder = Nothing
    Set myItems = Nothing
End Sub

[joe.levrai]

Bonjour,

je n'ai personnellement jamais copié un email pour le déplacer, sauf si j'ai besoin de le dupliquer

une autre proposition, utilisant la méthode Restrict pour filtrer directement la collection des Items du Folder, évitant ainsi de tester chaque mail dans la boucle de déplacement.

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
Sub copyItems()
Dim I As Long
Dim myInbox As Outlook.Folder, myDestFolder As Outlook.Folder, myItems As Outlook.Items
Dim LeMot As String, LeFiltre As String
 
' Méthode pour retourner une collection d'éléments en fonction d'un critère
' Ici le critère est basé sur "L'objet du mail contient MonMot"
' (ça remplace l'utilisation d'un Like ou d'un Instr qui serait à appliquer sur chaque élément)
MonMot = "Mail delivery"
LeFiltre = "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" like '%" & MonMot & "%'"
 
Set myInbox = Session.PickFolder
Set myDestFolder = Session.PickFolder
Set myItems = myInbox.Items.Restrict(LeFiltre)  ' la collection des mails filtrés
    For I = myItems.Count To 1 Step -1          ' une boucle For Each était également possible
        myItems(I).Move myDestFolder
    Next I
Set myInbox = Nothing
Set myDestFolder = Nothing
Set myItems = Nothing
End Sub

Ps : en automation Excel vers Outlook, j'évite au maximum de travailler sur l'objet Session et lui préfère une instanciation complète du client
De même, privilégier les liaisons tardives (même si ça ralentit l'exécution) afin de se décharger des problèmes de références manquantes si on doit travailler sur différents PC
Mais ça, c'est une préférence perso

Code :

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

1
2
3
4
5
6
7
Public OlApp As Object      ' Outlook.Application
Public OlNmSpace As Object  ' Outlook.NameSpace
Sub InitialisationOutlook()
    On Error Resume Next: Set OlApp = GetObject(, "Outlook.Application"): On Error GoTo 0
    If OlApp Is Nothing Then Set OlApp = CreateObject("Outlook.Application")
    Set OlNmSpace = OlApp.GetNamespace("MAPI")
End Sub

EDIT : au fait, si le dossier de destination et/ou le dossier source est toujours le même, on peut alléger grandement le code

[nonesofar]

Merci joe.levrai et parmi pour votre aide.

Alors pour expliquer plus en détails mon projet et pourquoi je veux copier des emails.

En fait je souhaite obtenir sur excel le nom des pièces jointes en fonction du nom du mail, depuis une boite commune.

Donc j'ai crée un dossier sur la boite perso et je récupère les emails dans le dossier, d'ou le code copier email dans un autre dossier.

Puis j'ai une macro qui récupère sur une feuille excel le nom des PJ (code opérationnel).

Le probléme c'est que j'ai trop de mails à copier et la macro est longue. Il faut que je filtre sur une plage de date, si vous avez une piste je suis preneur .

Voila sinon les codes sont tops je vais les tester.

[joe.levrai]

Bonjour,

par ici pour filtrer en fonction d'une date : https://www.developpez.net/forums/d1...k/#post8971053

encore et toujours la méthode Restrict, plus puissante que Find si tu as beaucoup d'éléments

[nonesofar]

Merci joe.levrai super boulot sur la méthode restrict.

Du coup j'ai adapté à mon sujet.

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
Sub moveItemsfilter()
Dim I As Long
Dim myInbox As Outlook.Folder, myDestFolder As Outlook.Folder, myItems As Outlook.Items
Dim LeMot As String, LeFiltre As String
 
DateFin = "01/05/2017"
 
LeFiltre = "[Receivedtime] > '" & Format((DateFin), "dd/mm/yyyy hh:mm") & "'"
' parmi les mails du dossier, j'applique la restriction
 
MonMot = "test - Fichier de Collecte"
LeFiltre = "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" like '%" & MonMot & "%'"
 
'Dans ton exemple tu utilises  With ActiveExplorer.CurrentFolder mais du coup vu que j'ai deux boites mails ou je dois passer les emails d'une vers l'autre.
Ce que j'ai fait ne fonctionne pas
 
Set myInbox = Session.PickFolder 'selection sous dossier boite 1  au j'ai les mails sources
Set myDestFolder = Session.PickFolder 'selection sous dossier boite 2  au j'ai les uniquement les emails souhaités
Set MesMailsInitial = myInbox.Items.Restrict(LeFiltre)
 
Set myItems = MesMailsInitial.Restrict(LeFiltre)  ' la collection des mails filtrés
    For I = myItems.Count To 1 Step -1          ' une boucle For Each était également possible
            Set Copie = myItems(I).Copy
            Copie.Move myDestFolder
    Next I
Set myInbox = Nothing
Set myDestFolder = Nothing
Set myItems = Nothing
End Sub