Discussion :

[don_pets]

Bonjour le fofo,

je me suis basé sur les différents posts, explications et discussions avec Oliv, pour pondre une macro qui enregistre les emails dans un répertoire de Windows. Mon souci vient du fait que j'ai deux cas de figure : ou bien le dossier existe déjà ou bien il faut le créer.

J'ai donc incorporé un test d'existence tout simple :

Code vb :

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

1
2
3
4
5
 
app = InputBox(" C'est pour quiqui ?")
ChDir "D:\Users\Documents\Messagerie\Apporteurs\" & app & "\"
If Error Then MkDir "D:\Users\Documents\Messagerie\Apporteurs\" & app & "\"
On Error GoTo 0

La dessus pas de souci, je tapote un nom, il existe, tant mieux, mes mails se collent dedans, il n'existe pas et ma macro le créera pour moi (par ce qu'elle est sympa).

Mon souci vient du fait que je peux faire de la multi sélection et là c'est pénible puisque ma fenêtre de demande de validation de nom reviendra autant de fois que j'ai de mails sélectionnés !

J'ai croisé dans mes lectures du matin des échanges entre Oliv et un User sur un problème quasi similaire, mais je n'ai pas réussit à m'en dépatouiller.

A toute fin utile voici mon code complet très très très largement inspiré de celui d'Oliv:

code de sélection :

Code vb :

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
Sub LanceSurSelection()
 
    ' Sélection des mails
 
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 "Pfiouu enfin terminé, et avec succès !!"
End Sub

code d'export sous win :

Code vb :

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
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
 
 
    ' Exporter des mails
On Error Resume Next
If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
 
NomExport = "Exp" & " " & objCurrentMessage.SenderName & " - " & "Dest" & " " & objCurrentMessage.To & " - " & "Obj" & " " & objCurrentMessage.Subject & " - " & "Date" & " " & Jour & "-" & Mois & "-" & Annee & "  " & Heure
 
app = InputBox(" C'est pour quiqui ?")
 
ChDir "D:\Users\marcel\Documents\Messagerie\Apporteurs\" & app & "\"
If Error Then MkDir "D:\Users\Documents\Messagerie\Apporteurs\" & app & "\"
On Error GoTo 0
repertoire = "D:\Users\Documents\Messagerie\Apporteurs\" & app & "\"
PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
n = 1
MemPath = PathNomExport
While Dir(PathNomExport) <> ""
MsgBox "L'Email " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
n = n + 1
 
Wend
 
objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
objCurrentMessage.Delete
 
End Sub

Merci par avance,

Pets

[Oliv-]

salut,

est ce que tu parles de ce message là ?

Code :

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

app = InputBox(" C'est pour quiqui ?")

Si tu déclares en haut de ton module

Code :

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

public app

tu peux tester

Code :

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

1
2
3
4
 
if app <>"" then 
app = InputBox(" C'est pour quiqui ?")
End if

as tu consulter ceT ARTICLE : c'est une évolution du code que tu dois utilisé en plus la fonction waaps_creedir permet de créer les dossier de façon récursive et
http://www.developpez.net/forums/blo...le-disque-msg/

[don_pets]

Oui oui, je l'ai lu et relu, mais comme je suis quelque peu néophyte et surtout sans bagage technique autre que l'apprentissage autodidacte, je ne percute pas tout et je jongle avec les données.

Pour résumer ce que tu viens d'écrire de devrais avoir ceci dans mon module :

Code vb :

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
Public app
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
 
    ' Exporter des mails
On Error Resume Next
If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
 
NomExport = "Exp" & " " & objCurrentMessage.SenderName & " - " & "Dest" & " " & objCurrentMessage.To & " - " & "Obj" & " " & objCurrentMessage.Subject & " - " & "Date" & " " & Jour & "-" & Mois & "-" & Annee & "  " & Heure
    If app <> "" Then
        app = InputBox("Nom de l'affaire / apporteur ?")
    End If
 
ChDir "D:\Users\marcel\Documents\Messagerie\Apporteurs\" & app & "\"
If Error Then MkDir "D:\Users\marcel\Documents\Messagerie\Apporteurs\" & app & "\"
On Error GoTo 0
repertoire = "D:\Users\marcel\Documents\Messagerie\Apporteurs\" & app & "\"
PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
n = 1
MemPath = PathNomExport
While Dir(PathNomExport) <> ""
MsgBox "L'Email " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
n = n + 1
 
Wend
 
objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
objCurrentMessage.Delete
 
End Sub

Sauf qu'en faisant ça, il ne me demande plus rien et il va me coller les mails, à la source mon dossier !

Merci pour ton coup de main !

[Oliv-]

NON je me suis trompé

Code :

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

if app =""

[don_pets]

Au top tellement ça marche,

Je dirais même c'est beau tellement c'est beau.

Pour les users qui chercheraient un script pour extraire des messages en sélection et les coller dans un répertoire dont on détermine à chaque action le nom (et que le ou les mails en question dégage(nt) dans les éléments supprimés, le voici :

Sélection :

Code vba :

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
 
Sub LanceSurSelection()
 
    ' Sélection des mails
 
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 "Pfiouu enfin terminé, et avec succès !!"
End Sub

L'extraction des mails :

Code vba :

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
 
Public app
Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
 
    ' Exporter des mails
On Error Resume Next
If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 
Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
 
NomExport = "Exp" & " " & objCurrentMessage.SenderName & " - " & "Dest" & " " & objCurrentMessage.To & " - " & "Obj" & " " & objCurrentMessage.Subject & " - " & "Date" & " " & Jour & "-" & Mois & "-" & Annee & "  " & Heure
 
    If app = "" Then
        app = InputBox("Nom de l'affaire / apporteur ?")
    End If
 
ChDir "D:\Users\marcel\Documents\Messagerie\Apporteurs\" & app & "\"
If Error Then MkDir "D:\Users\Documents\Messagerie\Apporteurs\" & app & "\"
On Error GoTo 0
repertoire = "D:\Users\Documents\Messagerie\Apporteurs\" & app & "\"
PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
n = 1
MemPath = PathNomExport
While Dir(PathNomExport) <> ""
MsgBox "L'Email " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
n = n + 1
 
Wend
 
objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
objCurrentMessage.Delete
 
End Sub

Encore merci Oliv pour ta précieuse aide,

Pet's