Save mail attachments with correct timestamp

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