Ultimately it boils down to staff ensuring the necessary flags are available. One possibility is to use a macro to save a dated copy of the current message into a hard drive folder that reflects the client name and the job number.
The following will do that. It prompts for a name and a job number and includes code to create folders, remove illegal filename characters and avoid overwriting similarly named files. The process still requires the user to run the macro, and in a real world situation it could be tidied up to read clients from a data file into a userform to cut down on pilot error, but it will save your messages:
Code:
Option Explicit
Sub SaveClientMessage()
'Graham Mayor - http://www.gmayor.com - Last updated - 12 Jul 2018
Const strPath As String = "C:\Path\" ' the root folder in which to save the messages
Dim strJobNum As String
Dim strClient As String
Dim strSavePath As String
Dim olMsg As MailItem
strClient = InputBox("Enter Client Name")
If strClient = "" Then
Beep
MsgBox "No client entered - start again!"
GoTo lbl_Exit
End If
strClient = CleanFileName(strClient)
strJobNum = InputBox("Enter Job Number")
If strJobNum = "" Then
Beep
MsgBox "No job number entered - start again!"
GoTo lbl_Exit
End If
strJobNum = CleanFileName(strJobNum)
strSavePath = strPath & strClient & "\" & strJobNum & "\"
CreateFolders strSavePath
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveMessage olMsg, strSavePath
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub
Private Sub SaveMessage(olItem As MailItem, sPath As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & " - " & 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, sPath, fname
lbl_Exit:
Exit Sub
End Sub
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strfilename As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strfilename)
Do While oFSO.FileExists(strPath & strfilename & ".msg") = True
strfilename = Left(strfilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strfilename & ".msg"
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function
Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function
Private Function CleanFileName(strfilename As String) As String
'Graham Mayor
'A function to ensure there are no illegal filename
'characters in a string to be used as a filename
Dim arrInvalid() As String
Dim lngIndex As Long
CleanFileName = strfilename
'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Remove any illegal filename characters
For lngIndex = 0 To UBound(arrInvalid)
CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lngIndex)), Chr(95))
Next lngIndex
lbl_Exit:
Exit Function
End Function