Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg
par
, 12/02/2016 à 15h13 (3773 Affichages)
Bonjour,
c'est une mise à jour de la faq : http://outlook.developpez.com/faq/?p...#VBA_save_mail
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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153 Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire) '--------------------------------------------------------------------------------------- ' Procedure : SavAs_mail_as_msg ' Author : Oliv ' Date : 12/02/2016 modifié 01/07/2020 ' Purpose : '--------------------------------------------------------------------------------------- ' ' exemple repertoire = "c:\mail\" Dim NomExport As String Dim PathNomExport As String Dim n As Integer Dim MemPath As String 'Ici on construit le nom du fichier qui sera créé 'par exemple : DATE CREATION + EXPEDITEUR + SUJET Dim Expediteur Expediteur = Get_sender_SMTP(MyMail) NomExport = Format(MyMail.CreationTime, "yyyymmdd hh:nn") & "-" & Expediteur & "-" & MyMail.Subject NomExport = remplaceCaracteresInterdit(NomExport) 'Ici on vérifie le répertoire où l'enregistrer If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\" Call waaps_creedir(CStr(repertoire)) 'On construit le chemin et le nom du fichier pour l'export PathNomExport = repertoire & Left(NomExport, 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 MyMail.SaveAs PathNomExport, OlSaveAsType.olMSG ' pour changer la date du fichier (voir en bas) ' Call ModifDate(CStr(PathNomExport), MyMail.CreationTime, 4) 'on peut aussi l'enregistrer dans d'autres formats 'Type de fichier à enregistrer. Il peut s'agir d'une des constantes OlSaveAsType suivantes : olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal ou olMSGUnicode. End Sub Function remplaceCaracteresInterdit(ByVal CheminStr As String) Dim objCurrentMessage As Outlook.MailItem Dim liste As Variant Dim L liste = Array("\", "/", ":", "*", "?", "<", ">", "|", """", vbTab, Chr(7)) For L = 0 To UBound(liste) CheminStr = Replace(CheminStr, liste(L), "") Next L remplaceCaracteresInterdit = Trim(CheminStr) 'MsgBox CheminStr End Function Function waaps_creedir(lerep As String) As Boolean '---------------------------------------------------------------------- ' FUNCTION : waaps_creedir ' Création d'un répertoire (récursif) '---------------------------------------------------------------------- ' Paramètres : ' rep : répertoire à créer par son chemin relatif % au root '---------------------------------------------------------------------- ' retour : True si le répertoire est créé '---------------------------------------------------------------------- ' Global utilisé : REP_TOP '---------------------------------------------------------------------- ' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA ' Utilisation commerciale interdite ' Utilisation personnelle / professionnelle autorisée ' Le message courant doit être préservé '---------------------------------------------------------------------- Dim FSO As Object, i As Integer, retour As Boolean Dim rp As String, r Dim rep As Variant Dim REP_TOP As String Set FSO = CreateObject("Scripting.filesystemobject") rp = Replace(lerep, "\", "/") rp = Replace(rp, "//", "/") rep = Split(rp, "/") r = REP_TOP retour = True For i = 0 To UBound(rep) If (rep(i) <> "") Then r = r & rep(i) & "\" If (Not FSO.FolderExists(r)) Then FSO.CreateFolder (CStr(r)) If (Not FSO.FolderExists(r)) Then retour = False End If End If Next Set FSO = Nothing waaps_creedir = retour End Function Private Function Get_sender_SMTP(Oitem As Outlook.MailItem) As String Dim oEU As Outlook.ExchangeUser On Error Resume Next Set oEU = Oitem.Sender.GetExchangeUser Get_sender_SMTP = oEU.PrimarySmtpAddress If Get_sender_SMTP = "" Then Get_sender_SMTP = GetFromFromHeader(Oitem) If Get_sender_SMTP = "" Then Get_sender_SMTP = Oitem.SenderEmailAddress End Function Function GetFromFromHeader(objMail As Outlook.MailItem) As String '--------------------------------------------------------------------------------------- ' Procedure : GetToFromHeader ' Author : OLIV- from original code brettdj ' Date : 04/06/2015 ' Purpose : '--------------------------------------------------------------------------------------- ' Dim objRegex As Object Dim objRegM As Object Dim MailHeader As String Dim ExtractText As String Dim i Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F" MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS) Set objRegex = CreateObject("vbscript.regexp") With objRegex .ignorecase = True .Pattern = "(\n)From:.*<(.+)>" If .test(MailHeader) Then Set objRegM = .Execute(MailHeader) For i = 0 To objRegM(0).submatches.Count - 1 If InStr(1, objRegM(0).submatches(i), "@", vbTextCompare) Then GetFromFromHeader = objRegM(0).submatches(i) Exit For End If Next i Else GetFromFromHeader = "" End If End With End Function
Une macro pour le lancer sur le mail actif :
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 Private Sub Test_SavAs_mail_as_msg() Dim obj As Object Set obj = Application.ActiveWindow If TypeOf obj Is Outlook.Inspector Then Set obj = obj.CurrentItem Else Set obj = obj.Selection(1) End If If obj.Class <> olMail Then Exit Sub Dim oMail As Outlook.MailItem Set oMail = obj Call SavAs_mail_as_msg(oMail , "c:\Dossier_export\") End Sub
Un script pour l'utiliser avec une "règle"
Code VBA : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3 Sub regle_exportMSG(Mail As Outlook.MailItem) Call SavAs_mail_as_msg(oMail , "c:\Dossier_export\") End Sub
exemple là :http://www.developpez.net/forums/d15...elon-criteres/
exemple ici avec un traitemen récursif
https://www.developpez.net/forums/d2.../#post11588093
Si on veut modifier la date du fichier .msg pour correspondre à la date du Mail
A METTRE DANS UN 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
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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128 'http://www.cathyastuce.com/vba/code-source-excel/manipulation-fichiers/420-modif-dates.html Public Const OFS_MAXPATHNAME = 260 Type OFSTRUCT cBytes As Byte fFixedDisk As Byte nErrCode As Integer Reserved1 As Integer Reserved2 As Integer szPathName(OFS_MAXPATHNAME) As Byte End Type Type FILETIME dwLowDate As Long dwHighDate As Long End Type Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMillisecs As Integer End Type ' constante Public Const FILE_SHARE_READ = &H1 Public Const FILE_SHARE_WRITE = &H2 Public Const GENERIC_WRITE = &H40000000 Public Const OPEN_EXISTING = 3 ' declarations api Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _ (ByVal lpFileName As String, _ ByVal dwDesiredAccess As Long, _ ByVal dwShareMode As Long, _ ByVal lpSecurityAttributes As Long, _ ByVal dwCreationDisposition As Long, _ ByVal dwFlagsAndAttributes As Long, _ ByVal hTemplateFile As Long) As Long Declare Function LocalFileTimeToFileTime Lib "kernel32" _ (lpLocalFileTime As FILETIME, _ lpFileTime As FILETIME) As Long Declare Function SetFileTime Lib "kernel32" _ (ByVal hFile As Long, _ lpcreation As FILETIME, _ lpLecture As FILETIME, _ lpLastWriteTime As FILETIME) As Long Declare Function GetFileTime Lib "kernel32" _ (ByVal hFile As Long, lpCreationTime As FILETIME, _ lpLastAccessTime As FILETIME, _ lpLastWriteTime As FILETIME) As Long Declare Function SystemTimeToFileTime Lib "kernel32" _ (lpSystemTime As SYSTEMTIME, _ lpFileTime As FILETIME) As Long Declare Function FileTimeToSystemTime Lib "kernel32" _ (lpFileTime As FILETIME, _ lpSystemTime As SYSTEMTIME) As Long Public Function GetFT(sDate) As FILETIME Dim udtSysTime As SYSTEMTIME Dim udtLocalTime As FILETIME Dim Ft As FILETIME Dim RetVal As Long With udtSysTime .wYear = Year(sDate) .wMonth = Month(sDate) .wDay = Day(sDate) .wDayOfWeek = Weekday(sDate) - 1 .wHour = Hour(sDate) .wMinute = Minute(sDate) .wSecond = Second(sDate) End With RetVal = SystemTimeToFileTime(udtSysTime, udtLocalTime) RetVal = LocalFileTimeToFileTime(udtLocalTime, GetFT) End Function Public Function GetFileDateString(CT As FILETIME, sFormat As String) As String Dim ST As SYSTEMTIME Dim ds As Single 'Convertir les infos du fichier en un format temps affichable If FileTimeToSystemTime(CT, ST) Then ds = DateSerial(ST.wYear, ST.wMonth, ST.wDay) GetFileDateString = Format$(ds, sFormat) Else GetFileDateString = "" End If End Function '******** MODIFIER UN FICHIER *********************** Public Sub ModifDate(sNomFichier As String, sDate As String, byType As Byte) 'byType = 1 =>Date de creation 'byType = 2 =>Date de Lecture 'byType = 3 =>Date derniere ecriture 'byType = 4 => toutes Dim hFile As Long Dim Ft As FILETIME Dim FTc As FILETIME Dim FTa As FILETIME Dim FTw As FILETIME Dim RetVal As String hFile = CreateFile(sNomFichier, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0) GetFileTime hFile, FTc, FTa, FTw Select Case byType Case 1 ' modification Date de creation Ft = GetFT(sDate) RetVal = SetFileTime(hFile, Ft, FTa, FTw) Case 2 ' modification Date de Lecture Ft = GetFT(sDate) RetVal = SetFileTime(hFile, FTc, Ft, FTw) Case 3 ' modification Date derniere ecriture Ft = GetFT(sDate) RetVal = SetFileTime(hFile, FTc, FTa, Ft) Case 4 ' modification toutes Ft = GetFT(sDate) RetVal = SetFileTime(hFile, Ft, Ft, Ft) End Select End Sub
Dans la macro principale dé-commentez la ligne
Code vb : Sélectionner tout - Visualiser dans une fenêtre à part Call ModifDate(CStr(PathNomExport), MyMail.CreationTime, 4)