[OL-2003] Ranger un mail dans un dossier en fonction de son objet [Résolu]

[FCL31]

Bonjours a tous et bonne année

J'utilise 2 codes :
- le premier pour modifier l'objet d'un mail :

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 Objet_CN()
 
    Dim Exp As Explorer
    Dim Sel As Selection
    Dim Itm As MailItem
 
 
    Set Exp = ActiveExplorer
    Set Sel = Exp.Selection
 
    For Each Itm In Sel
        Itm.Subject = Format(Itm.ReceivedTime, "yyyy/mm/dd") & " _ CN _ " & Itm.Subject
        Itm.Subject = Replace(Itm.Subject, "/", "-")
 
        Itm.Save
 
 
    Next Itm
 
        Set Itm = Nothing
        Set Sel = Nothing
        Set Exp = Nothing
 
End Sub
 '-------------------------------------------------------------------------
Sub Objet_FR()
 
    Dim Exp As Explorer
    Dim Sel As Selection
    Dim Itm As MailItem
 
 
    Set Exp = ActiveExplorer
    Set Sel = Exp.Selection
 
    For Each Itm In Sel
        Itm.Subject = Format(Itm.ReceivedTime, "yyyy/mm/dd") & " _ FR _ " & Itm.Subject
        Itm.Subject = Replace(Itm.Subject, "/", "-")
 
        Itm.Save
 
 
    Next Itm
 
        Set Itm = Nothing
        Set Sel = Nothing
        Set Exp = Nothing
 
End Sub

qui me donne un truc du style :

Document

qui devient

2011-12-21 _ CN _ Document

-le second code me sert a ranger mon mail dans un dossier :

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
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éfini le répertoire où l'enregistrer
    repertoire = "\\Hp\FCL\Messages Outlook\"
    'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
        '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

Mes 2 codes marche mais je voudrais modifier le second pour que mon mail soit ranger dans le dossier en fonction de l'objet.
Par exemple dans ce cas, le mail "2011-12-21 _ CN _ Document" doit étre ranger dans le dossier "\\Hp\FCL\Messages Outlook\CN\"

PS : mon premier code existe plusieurs fois en remplaçant CN par FR ou CC ou MO.
J'ai donc plusieurs modification d'objet possible

En espérant avoir été suffisamment clair, merci d'avance de votre aide.

[FCL31]

J'ai plus ou moins résolu mon problème avec le code suivant:

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
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
    NomDos = Mid(objCurrentMessage.Subject, 14, 5)
    'Ici on défini le répertoire où l'enregistrer
 
    If NomDos = "CN  _" Then
        repertoire = "\\Hp\FCL\Messages Outlook\CN\"
    Else
    If NomDos = "FR  _" Then
        repertoire = "\\Hp\FCL\Messages Outlook\FR\"
    End If
    End If
 
 
    'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
        '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

Le problème est qu'il y a 16 lignes semblable à :

Code :

1
2
3
4
    If NomDos = "FR" Then
        repertoire = "\\Hp\FCL\Messages Outlook\FR\"
 
    End If

Sa fait un peu beaucoup

Y a t'il un moyen de simplifier ???

Et si "NomDos" ne correspond a rien comment faire en sorte que le mail soit envoyé dans un autre dossier "A Trier" par exemple dans "\\Hp\FCL\Messages Outlook\" ???

[carden752]

Bonjour,

Pourquoi ne pas utiliser la fonction mid pour couper une chaine de caractère.

Quelque chose de ce style :

Code :

 repertoire = "\\Hp\FCL\Messages Outlook\" & mid(NomDos,2) & "\"

[FCL31]

Je vois se que tu veu dire mais malheureusement ton solution ne peut pas fonctionner dans tous les cas.

En effet j'ai des cas qui vont resembler à :

Code :

1
2
3
4
    If NomDos = "CT" Then
        repertoire = "\\Hp\FCL\Messages Outlook\Contrat\"
 
    End If

[bbil]

bonsoir,

un Select Case :

Code :

1
2
3
4
5
6
7
8
Select Case NomDos
    Case "CN  _"
        repertoire = "\\Hp\FCL\Messages Outlook\CN\"
    Case "FR"
        repertoire = "\\Hp\FCL\Messages Outlook\FR\"
 Case Else
  repertoire = "\A_TRIER\"
 End Select

[FCL31]

beaucoup pour votre aide.

Je crois (grâce a vous) avoir reussi se que je voulais.