Microsoft Office Forums - View Single Post - Change subject to include date and time in subject

gmayor · 05-01-2015, 09:58 PM

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.

Code:

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