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 |
