Discussion :

[rmgringo]

Bonjour à tous
sujet déjà ouvert et résolu mais pas pour moi

Lorsque j'enregistre un email Outlook 2010 en fichier .MSG dans un dossier de Windows la date celui-ci est par défaut la date de l'enregistrement et je souhaiterais pouvoir avoir
la date d'envoi/réception de cet email.

Y aurait il un moyen de récupérer cette date vu qu'elle se trouve dans le message ?

Merci d'avance,

[Oliv-]

bonjour,
voir ici http://www.developpez.net/forums/d15...s/#post8536215

[rmgringo]

Cool merci je vais regarder Mais oups je suis pas expert en VBA
à suivre...

[rmgringo]

Trop compliqué pour moi je ne suis pas programmeur

y aurait pas une fonction qui me permet juste d'enregistrer le mail sélectionné et de l'enregistrer dans un répertoire spécifié avec la date de création de l'email (oui je sais je me répète)

Merci de votre aide

[Oliv-]

Bonjour,
la seule solution c'est de passer par une macro ou un programme tiers.

Voici la macro plus détaillée. (si tu fais des macros excel c'est pareil ou presque)

Tu crées un module où tu mets :

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
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

et un second module où tu mets

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
Sub SavAs_mail_as_msgDate(MyMail As Outlook.MailItem, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : SavAs_mail_as_msg
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   : modifiée pour changer la date systeme du fichier .msg
'---------------------------------------------------------------------------------------
'
' 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
    call waaps_creedir (repertoire)
 
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 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
    Call ModifDate(CStr(PathNomExport), MyMail.CreationTime, 4)
End Sub
 
 
 
 
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 FileSystemObject, 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
 
 
Private Sub Test_SavAs_mail_as_msg()
    Dim oMail As Outlook.MailItem
    Set oMail = ActiveInspector.CurrentItem
    Call SavAs_mail_as_msg(oMail , "c:\Dossier_export\")
End Sub

Et tu lances Test_SavAs_mail_as_msg à partir du mail ouvert que tu veux exporter .

Est ce encore trop compliqué ?

[rmgringo]

Merci Cool
pourquoi 2 modules ?

[rmgringo]

J'ai essayé j'ai une erreur ?
merci

[Oliv-]

Oui parce que je j'ai changé le nom

il faut mettre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Private Sub Test_SavAs_mail_as_msg()
    Dim oMail As Outlook.MailItem
    Set oMail = ActiveInspector.CurrentItem
    Call SavAs_mail_as_msgDate(oMail , "c:\Dossier_export\")
End Sub

[rmgringo]

Hello,

J'ai encore une erreur ?

[Oliv-]

Bonjour,
Ce n'est pas vraiment un erreur, il faut juste que le mail que tu veux exporter soit OUVERT et pas juste sélectionné.

[rmgringo]

Ah ok merci je savais pas

Par contre j'ai un autre message d'erreur au niveau de (repertoire)

[Oliv-]

remplace la ligne par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 call waaps_creedir (cstr(repertoire))

[rmgringo]

j'ai encore une nouvelle erreur ?

[Oliv-]

Tu peux changer par
Dim fso as object

[rmgringo]

ça Marche un grand merci