Change subject to include date and time in subject

[officechris]

In my line of work I receive about 400+ emails daily, with multiple people responding back and forth, not always on the most current message.

I need to be able to save all the messages into a folder on my network, but when the subject line is the same, it forces me to copy and replace.

I am looking for a way that I can have the subject be changed, so that it has the date and time it was sent in the subject line. That way the subject is different enough so it can save in the folder, but similar enough so if I need to search by subject key words, all the email from that chain will pull up.

I have looked in to a rule using scripts, but I don't have a programming background, and would need someone to write the script for me, or point me in the right direction.



Or if someone else has a better idea I am all ears.

[gmayor]

The following macros will save the messages without overwriting any existing messages with the same filename (whether or not you include the date - I have left it optional).

The main SaveMessage macro can be run as a script from a rule to save the messages as they arrive, to the named folder.

You can test it with TestMacro. Select a message and run the TestMacro several times to see how it handles filenames that exist.

Although aimed at Word the process at http://www.gmayor.com/installing_macro.htm is virtually identical for Outlook.

Option Explicit

Sub SaveMessage(olItem As MailItem)
Dim Fname As String
Dim fPath As String
    fPath = "C:\Path\" 'The folder to save the documents
    Fname = olItem.Subject
    'Next line is optional
    'Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
            Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & Fname
    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
lbl_Exit:
    Exit Sub
End Sub

Sub TestMacro()
Dim olMsg As MailItem
    On Error GoTo lbl_Exit
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveMessage olMsg
lbl_Exit:
    Exit Sub
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"
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function