Oliv-

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)