Microsoft Office Forums - View Single Post

gmayor · 07-12-2018, 05:31 AM

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