FYI:
I have made this VBA that saves all attachments (to all selected mails) to files.
WriteFiledate, CreateFiledate and AccessFiledate of these files are assigned the value of SentOn for the mail.
I am using Function AdjustFileTime from MrExcel.
Option Explicit
Sub HVL_Save_Attachments_to_Desktop()
' All attachments in selected mails are saved to Desktop.
' WriteFileDate, CreateFileDate and AccessFileDate are given the value of SentOn.
Dim aMailItem As Object ' MailItem or MeetingItem or ...
Dim Attach As Outlook.Attachment
Dim FS As New Scripting.FileSystemObject
Dim nAttach As Integer
Dim aDate As Date
Dim aFilename As String
Dim aName As String
Dim anExt As String
Dim aPath As String
Dim aFullPath As String
Dim N As Integer
Dim S As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim ret As Long
aPath = CreateObject("WSCript.Shell").SpecialFolders("Desktop")
N = 0
' All selected items
For Each aMailItem In Application.ActiveExplorer.Selection
' Only mails
If aMailItem.Class = olMail Or _
aMailItem.Class = olMeetingRequest Then
' Any attachments?
nAttach = aMailItem.Attachments.Count
If nAttach > 0 Then
aDate = aMailItem.SentOn ' Mail Sent
' All attachments
For i = 1 To nAttach
Set Attach = aMailItem.Attachments(i)
aFilename = Attach.FileName ' .DisplayName
j = InStrRev(aFilename, ".")
aName = Left(aFilename, j - 1)
anExt = Right(aFilename, Len(aFilename) - j)
aFullPath = aPath & "\" & aName & "." & anExt
' Existing file?
k = 0
Do While FS.FileExists(aFullPath)
k = k + 1
aFullPath = aPath & "\" & aName & " (" & k & ")." & anExt
Loop
' Save file
Attach.SaveAsFile (aFullPath)
N = N + 1
' Change timestamps of file
ret = AdjustFileTime(aFullPath, aDate, aDate, aDate)
Next i
End If
End If
Next aMailItem
' Message
If N = 0 Then
S = "No attachments found!"
ElseIf N = 1 Then
S = N & " attachment saved!"
Else
S = N & " attachments saved!"
End If
MsgBox S, vbInformation, "Mail attachments saved to Desktop"
Set aMailItem = Nothing
Set Attach = Nothing
Set FS = Nothing
End Sub