Microsoft Office Forums - View Single Post

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