Voir le flux RSS

Oliv-

Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg

Noter ce billet
par , 12/02/2016 à 15h13 (1406 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
Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : SavAs_mail_as_msg
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
' exemple repertoire = "c:\mail\"
 
 
    'Ici on construit le nom du fichier qui sera créé
    NomExport = MyMail.subject & MyMail.CreationTime
 
    'Ici on vérifie le répertoire où l'enregistrer
    If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
 
    'on vérifie s'il existe sinon on le crée
     repertoire=remplaceCaracteresInterdit(repertoire)
 
    call waaps_creedir (cstr(repertoire))
 
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & "Email " & Left(remplaceCaracteresInterdit(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
 
    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


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/


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)

Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog Viadeo Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog Twitter Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog Google Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog Facebook Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog Digg Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog Delicious Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog MySpace Envoyer le billet « Outlook , enregistrer un élément (Email par Exemple) sur le disque en .msg » dans le blog Yahoo

Mis à jour 30/08/2019 à 13h59 par Oliv-

Catégories
vba outlook

Commentaires