Macro Outlook export format msg, répétition de la macro

Bonjour le fofo,

Je reviens vers vous pour un problème que j'ai depuis quelques temps mais que j'avais laissé dans un coin en me disant ce n'est pas grave, ce qui est vrai, mais du coup mon développement est incomplet.

Voici le concept de la macro :

Sur la boîte de réception, on sélectionne un ou plusieurs mails puis l'exécution de la macro permet d'exporter les mails dans un répertoire Windows (répertoire existant existant ou non). L'avantage c'est que cela libère de la place pour les messageries un peu short en espace disque alloué, et que les mails sont sous format .msg. Il est donc possible de les consulter, faire des recherches, répondre, consulter les PJ tout ça tout ça.

Cette macro fonctionne nickel (merci Oliv!) mais j'ai un juste un frein, c'est que je suis obligé de quitter Outlook er de le relancer à chaque execution de macro, sinon les mails vont venir se stocker dans le répertoire initialement demandé (pour faire simple, mon inputbox pour demander le nom du rep. n'apparaît pas.)

Voici le code :

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

Sub sav_mail_as_msg(Optional objCurrentMessage As Object)   ' Exporter des mails des Apporteurs   On Error Resume Next   If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem   ' Format Date Annee = Mid(objCurrentMessage.CreationTime, 7, 4) Mois = Mid(objCurrentMessage.CreationTime, 4, 2) Jour = Mid(objCurrentMessage.CreationTime, 1, 2) Heure = Mid(objCurrentMessage.CreationTime, 12, 5)   ' Créer format nom du Mail exporté NomExport = Jour & "-" & Mois & "-" & Annee & " " & Heure & " - " & "De" & " " & objCurrentMessage.SenderName & " - " & "À" & " " & objCurrentMessage.To & " - " & objCurrentMessage.Subject   ' Création ou non du dossier de destination If app = "" Then app = InputBox("Nom de l'affaire / apporteur ?") End If   ChDir "D:\Users\documents\Messagerie\Apporteurs\" & app & "\" If Error Then MkDir "D:\Users\documents\Messagerie\Apporteurs\" & app & "\" On Error GoTo 0   ' Copier le dossier repertoire = "D:\Users\Documents\Messagerie\" & 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 ' Sauvegarde et suppression du mail objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG objCurrentMessage.Delete

---

Si quelqu'un il a une idée je prends,

Cimer

don

Bonjour,
Il manque une partie de ton code , mais si tu mets à la fin ca doit corriger le pb

Code:

---

app =""

---

Salut Oliv,

Effectivement je n'ai pas collé la suite qui permet de faire de la multi sélection de mails :

Code :

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13

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 !!"

---

Ce qui fait que si je rajoute app="" à la fin de ma macro, la conséquence est que si je 35 mails à balancer dans le même dossier, l'inputbox reviendra autant de fois, mais sinon je te confirme que cela fonctionne

Citation:

---

Envoyé par don_pets

Salut Oliv,


Ce qui fait que si je rajoute app="" à la fin de ma macro, la conséquence est que si je 35 mails à balancer dans le même dossier, l'inputbox reviendra autant de fois, mais sinon je te confirme que cela fonctionne

---

NOn si c'est sur la ligne 11

Yeaaaaaaaaaaaaaaaaaaa,

ça tourne nickel,

Merci Oliv !