export emails

andyc209 · #1 11-28-2014, 02:45 AM

i have to search and evidence through 200,000 emails and send copies to someone - after getting search results when i drag out the emails to a folder on my desktop how can still order them by date received or sent. The date modified is the date and time i dragged them out. If i click on the toolbar and add Date Received as a column it shows as blank.

gmayor · #2 11-29-2014, 01:50 AM

When you drag a message to the desktop you essentially save it as a message file. You can do that instead with a macro that will name the file including the received date etc in the filename. Change the path from "C:\Path\" to a suitable location (the desktop is not ideal) and run GetMsg with the message in question selected. The additional function will ensure that files which would duplicate names are preserved. e.g.

20141129 03.48 Sender - Subject.msg
20141129 03.48 Sender - Subject(1).msg

Code:

Option Explicit
Sub GetMsg()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveMessage olMsg
End Sub

Sub SaveMessage(olItem As MailItem)
Dim Fname As String
Const fPath As String = "C:\Path\"

            Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
            Fname = Replace(Fname, Chr(58) & Chr(41), "")
            Fname = Replace(Fname, Chr(58) & Chr(40), "")
            Fname = Replace(Fname, Chr(34), "-")
            Fname = Replace(Fname, Chr(42), "-")
            Fname = Replace(Fname, Chr(47), "-")
            Fname = Replace(Fname, Chr(58), "-")
            Fname = Replace(Fname, Chr(60), "-")
            Fname = Replace(Fname, Chr(62), "-")
            Fname = Replace(Fname, Chr(63), "-")
            Fname = Replace(Fname, Chr(124), "-")
            SaveUnique olItem, fPath, Fname
End Sub

Private Function SaveUnique(oItem As Object, _
                           strPath As String, _
                           strFilename As String)
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFilename)
    Do While FileExists(strPath & strFilename & ".msg") = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFilename & ".msg"
End Function

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Export to Pdf	JohnBi	Word VBA	0	07-06-2013 11:12 PM
Export Outlook emails to Access & parse certain text elements	smahale	Outlook	0	01-18-2012 09:30 PM
Import and Export of emails	JiminSA	Outlook	2	07-21-2011 04:22 AM
Outlook emails are marked as spam, but Gmail emails are not.	aquabob	Outlook	1	07-28-2010 11:41 AM
export outlook express emails to an account within outlook 2003	zillah	Outlook	0	11-23-2009 03:20 AM