This is a script that I wrote that will run through a folder of .msg files and replace the email “Received Date” with the original date, because sometimes copying or moving an email using POP3 or IMAP will set a new creation date that Outlook will then display, so you get a mailbox full of emails that are the same date. You may need to change the "X-MDArrival-Date:" to whatever it is in your mail system. I’ve also packaged the VBA into an Access Database File he http://www.brightnet.co.uk/archives/1333


Private Sub ReplaceEmailReceivedDateWithDeliveryDate(strPath As Variant)
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
If IsNull(strPath) Then strPath = "C:\"
Set objFolder = objFSO.GetFolder(strPath)
For Each objFile In objFolder.Files
strFile = objFile.Name
If Right(strFile, 4) = ".msg" Then
strTemp = strFile & ".tmp"
'read existing file
Set objFile = objFSO.OpenTextFile(strPath & strFile, ForReading)
strText = objFile.ReadAll
objFile.Close
If InStr(strText, "X-MDArrival-Date:") Then
'make new file
Set tmpFile = objFSO.CreateTextFile(strPath & strTemp, True)
arrLines = Split(strText, vbCrLf)
For i = 0 To (UBound(arrLines))
If Left(arrLines(i), 17) = "X-MDArrival-Date:" Then
vLine1 = arrLines(i)
strDate1 = Mid(arrLines(i), 19)
End If
If Left(arrLines(i), 14) = "Delivery-Date:" Then
vLine2 = arrLines(i)
strDate2 = Mid(arrLines(i), 16)
End If
Next
If Not IsEmpty(vLine1) Then
For i = 0 To (UBound(arrLines))
If Left(arrLines(i), 17) = "X-MDArrival-Date:" Then
arrLines(i) = Replace(arrLines(i), vLine1, Replace(vLine2, "Delivery-Date:", "X-MDArrival-Date:"))
End If
If InStr(arrLines(i), strDate1) Then arrLines(i) = Replace(arrLines(i), strDate1, strDate2)
tmpFile.WriteLine arrLines(i)
Next
tmpFile.Close
objFSO.DeleteFile strPath & strFile, True
objFSO.MoveFile strPath & strTemp, strPath & strFile
End If
End If
End If
NextRow = NextRow + 1
Next objFile
End Sub