Discussion :

[aragdur]

Bonjour,

je suis sous Outlook 2010 au travail avec un quota ridicule qui me fait totalement cracker

Idéalement, je souhaiterai faire une macro qui me permettrait, toutes les heures, de transférer les mails de mon dossier "exemple 1" de ma boîte de réception vers le dossier "exemple 1" de mon archive.
J'ai trouvé le code suivant sauf qu'il s'agit de MAPI et que je suis sous Exchange donc ça ne fonctionne pas.

Pourriez-vous m'aider s'il vous plaît ?

@+

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 MoveItems()
'By Oliv' février 2007 
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = myOlApp.GetNamespace("MAPI")
'ici le dossier d'origine
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).folders("Divers")
Set myItems = myInbox.Items
'ici le dossier destination
Set myDestFolder = myNameSpace.Folders("Dossiers personnels").Folders("Divers")
For each Myitem in myItems
Myitem.Move myDestFolder
Next
Set myNameSpace=nothing
Set myInbox=nothing
Set myItems =nothing
Set myDestFolder =nothing

[Oliv-]

Bonjour,
Qu'est ce qui ne marche pas ?

Ton pst se nomme t'il bien "Dossiers personnels"

[aragdur]

Bonjour,
Qu'est ce qui ne marche pas ?

Ton pst se nomme t'il bien "Dossiers personnels"

salut,

bon j'ai changé le "Dossiers personnels" par "Archives" (nom de mon .pst).
Mais ça bug avant.

à la ligne [...]GetDefaultFolder(olFolderInbox).Folders("exemple 1")

j'ai bien ce dossier dans ma boîte de réception mais il ne trouve pas on dirait.
ce pourrait-il que ce soit à cause de l'utilisation de Exchange et non Mapi ?

cdlt

[Oliv-]

Il faut vérifier la casse et que ce soit bien un sous dossier de boite de reception.

[aragdur]

c'est bien un sous-dossier de boîte de réception et la casse est bonne.

l'erreur c'est :"impossible de trouver un objet"

cdlt

[Oliv-]

Essaye comme cela

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
Sub MoveItems()
'By Oliv' février 2007 
  Dim OL As Outlook.Application
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = OL.GetNamespace("MAPI")
'ici le dossier d'origine
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myInbox =myInbox.folders("Divers")
Set myItems = myInbox.Items
'ici le dossier destination
Set myDestFolder = myNameSpace.Folders("Dossiers personnels").Folders("Divers")
For each Myitem in myItems
Myitem.Move myDestFolder
Next
Set myNameSpace=nothing
Set myInbox=nothing
Set myItems =nothing
Set myDestFolder =nothing

[aragdur]

Salut,

merci pour ce code.
J'ai passé l'étape du dossier d'origine.
ça bloque maintenant au dossier de destination.
Il ne trouve pas mon "Dossiers personnels" ou le dossier "Divers".

est-ce qu'il y a un moyen d'identifier où cela bloque t'il stp ?

comment connaître le nom des "NameSpace" par exemple ?

cdlt

[Oliv-]

Salut

voici une petite modif qui te permettra d'identifier ton dossier destination

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
Sub MoveItems()
'By Oliv' février 2007 
  Dim OL As Outlook.Application
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = OL.GetNamespace("MAPI")
'ici le dossier d'origine
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myInbox =myInbox.folders("Divers")
Set myItems = myInbox.Items
'ici le dossier destination
Set myDestFolder = mynameSpace.PickFolder
msgbox myDestFolder.FolderPath 
 
'Set myDestFolder = myNameSpace.Folders("Dossiers personnels").Folders("Divers")
For each Myitem in myItems
Myitem.Move myDestFolder
Next
Set myNameSpace=nothing
Set myInbox=nothing
Set myItems =nothing
Set myDestFolder =nothing

[aragdur]

c'est fort ça !

mon dossier c'est :
"\\Dossiers personnels\Boîte de réception\Divers"

Ce qui veut dire qu'il faut que je mette "Boîte de réception\Divers" sinon ça ne fonctionne pas ?

cdlt

[Oliv-]

Code :

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

Set myDestFolder = myNameSpace.Folders("Dossiers personnels").Folders("Boîte de réception").Folders("Divers")

[aragdur]

c'est génial !
ça fonctionne presque parfaitement.

c'est comique car il me transfert les mails par date.
Par exemple, si j'ai :
- 24/04
- 25/05
-26/06,
il me transfert d'abord le plus vieux. Puis si j'active la macro, il transfert le deuxième plus vieux.

Si je veux faire ça pour tous mes dossiers et sous dossiers, je recopie "ici le dossier d'origine" ainsi que "ici le dossier destination", c'est ça ?

cdlt

[Oliv-]

par contre la prochaine fois que tu lances si le Mail existe toujouts dans le dossier d'origine tu auras un doublons dans le dossier destination !

[aragdur]

je ne peux pas avoir de doublons si mon mail est déplacé non ?

[Oliv-]

oups ! oui tu as raison je pensais que c'était une copie et non un move.

mais en fait ton code ne va pas fonctionner correctement il faut utiliser cette syntaxe

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
 
 
Sub MoveItems()
dim n
'By Oliv' février 2007 
  Dim OL As Outlook.Application
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = OL.GetNamespace("MAPI")
'ici le dossier d'origine
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myInbox =myInbox.folders("Divers")
Set myItems = myInbox.Items
'ici le dossier destination
Set myDestFolder = mynameSpace.PickFolder
msgbox myDestFolder.FolderPath 
 
'Set myDestFolder = myNameSpace.Folders("Dossiers personnels").Folders("Divers")
 
For n = myItems.Count To 1 Step -1
                Set myItem = myItems.Items(n)
Myitem.Move myDestFolder
Next n
 
 
Set myNameSpace=nothing
Set myInbox=nothing
Set myItems =nothing
Set myDestFolder =nothing

Si tu as juste quelques dossiers, tu peux répéter le code sinon il faut utiliser une fonction récursive.

https://www.developpez.net/forums/bl...sous-dossiers/

[aragdur]

Salut,

t'es un génie.
Pour le nombre de dossier, j'en ai clairement un sacré paquet.
sais-tu qu'elle est la limite ?

Je suis allé regardé ton autre post.
c'est du lourd, du méga lourd ^^'

Sinon, vu que je veux automatiser la chose, je pensais faire plus simple :
- faire une macro nominative ("Divers1" ; "Divers2" ; "Divers3" ; ...)
- faire une tâche planifiée par macro.

cdlt