Classer dans explorateur par destinataire

[Vbapprentis]

Bonsoir,


Serait il possible de balayer une liste de mail dans un dossier bien précis et de les classer par le destinataire

exemple
dans le dossier C:\mail

avoir au debut en vrac

envoi plans rdc.msg "dupont@wanadoo.fr"
envoi plans etage1.msg "matin@wanadoo.fr"
envoi plans etage2.msg "dupont@wandoo.fr"

ensuite çà donnerai

danc C:\mail
un dossier
C:\dupont@wanadoo.fr
envoi plan rdc.msg
envoi plan etage2.msg

c:\matin@wanadoo.fr
envoi plan etage1.msg

Merci

[Heureux-oli]

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
Sub SaveAtt()
Dim myFld As Folder
Dim myNS As NameSpace
Dim myItem As MailItem
Dim oApp As Outlook.Application
 
Set oApp = Outlook.Application
Set myNS = oApp.GetNamespace("MAPI")
Set myFld = myNS.GetDefaultFolder(olFolderInbox)
 
For Each myItem In myFld.Items
 
     Debug.print myItem.SenderName
 
 
Next myItem
 
 
End Sub

Ce code va récupérer le nom de l'expéditeur, à toi de savoir ce que tu veux faire ensuite.

[Oliv-]

Bonjour,
Voici à code à adapter, à partir des mails dans OUTLOOK
il faut vérifier si le repertoire correspondant au destinataire existe (dir) sinon le créer (md) voir l'aide.

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
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
'By Oliv' juillet 2007 pour OUTLOOK 2003
 
If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
'Ici on construit le nom du fichier qui sera créé
NomExport = objCurrentMessage.Subject & objCurrentMessage.CreationTime
 
'Ici on définit le répertoire où l'enregistrer
repertoire = "c:\temp\"
'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
 
'Ici on supprime les caractères non autorisés dans les noms de fichiers
PathNomExport = repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
n = 1
MemPath = PathNomExport
While Dir(PathNomExport) <> ""
MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
n = n + 1
 
Wend
    objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
 
End Sub
 
Sub LanceSurOuvert()
sav_mail_as_msg
End Sub
 
 
Sub LanceSurSelection()
Dim MonOutlook As Outlook.Application
Dim LeMail As Object
Dim LesMails As Outlook.Selection
Set MonOutlook = Outlook.Application
 
Set LesMails = MonOutlook.ActiveExplorer.Selection
 
    For Each LeMail In LesMails
    sav_mail_as_msg LeMail
    Next LeMail
 
Set LesMails = Nothing
MsgBox "Fin de traitement"
End Sub

Il faut exécuter LanceSurOuvert à partir de l'élément ouvert ou LanceSurSelection à partir d'une sélection d'éléments.

Si les mails sont déjà dans un dossier du disque dur, c'est un peu plus compliqué voir le fil suivant : http://www.developpez.net/forums/sho...d.php?t=449472

[Vbapprentis]

Bonjour,

merci pour vos solutions je vais tester