Bonjour,

Encore une fois un code qui m'a été bien utile. Je suis limité en taille de stockage sur ma boîte pro. Aussi dois-je souvent archiver, mais je n'aime pas trop les .pst parce que peu de gens le savent mais Microsoft ne garantit pas lui-même leur stabilité dès lors qu'ils dépassent un certain poids (de l'ordre de 3 à 5 go).

Donc pour m'éviter le stress d'avoir un dossier d'archives de 37 Go qui plante et que je perde tout ... Et autre raison et non des moindres, un pst ne peut être lu qu'en étant réinstallé sur un profil Outlook, ce qui est assez contraignant. J'ai donc cherché une solution plus pérenne. Et la voici :

L'idée, quand, avec mon activité, un dossier professionnel est bouclé, je le sauvegarde en l'exportant en .msg sur mon pc (ensuite j'ai des scripts dos qui me les sauvegardent automatiquement sur un externe). Aussi je sélectionne un ou plusieurs mails de mon dossier, et ma macro me demande le nom du répertoire de destination. Et pour que je puisse bien m'y repérer, chaque mail est renommé avec le nom de l'expéditeur - le nom du destinataire - Objet du mail - Date.

Comme ça au lieu de me prendre la tête à remettre tout un pst sur un profil je fais une recherche via l'explorateur Windows, et hop même si la chaîne de caractère cherchée est dans le corps du message je peux retrouver mon mail désiré, l'ouvrir sans Outlook (et même avoir les Pièces jointes en bonus).

Here we are :

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Public app
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 = "Exp" & " " & objCurrentMessage.SenderName & " - " & "Dest" & " " & objCurrentMessage.To & " - " & "Obj" & " " & objCurrentMessage.Subject & " - " & "Date" & " " & Jour & "-" & Mois & "-" & Annee & "  " & Heure
 
        ' Création ou non du dossier de destination
    If app = "" Then
        app = InputBox("Nom de l'affaire / apporteur ?")
    End If
 
ChDir "D:\Chemin\" & app & "\"
If Error Then MkDir "D:\Chemin\" & app & "\"
On Error GoTo 0
 
        ' Copier le dossier
repertoire = "D:\Chemin\" & 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
 
End Sub
 
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
Enjoy,

Si l'explication est peu claire, n'hésitez pas à me jeter des cailloux.

Pet's