Add-in to file messages?

Topic

New Reply

Just moved to Office365. Any experiences with a utility to file the messages? MessageFiler is in the Office store, and there’s another, QuickFile.

Reply | Quote

Replies

I have no idea about the quoted utilities, but you can save individual messages to a Windows folder with an Outlook macro (and it’s not much of a stretch to modify that to save a selection of messages, a folder full of messages or all messages) e.g.

Code:

Option Explicit

Sub SaveMessage()
‘An Outlook macro by Graham Mayor – www.gmayor.com
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub

Private Sub SaveItem(olItem As MailItem)
‘An Outlook macro by Graham Mayor – www.gmayor.com
Dim fname As String
Dim fPath As String
    fPath = InputBox(“Enter the path to save the message.” & vbCr & _
                     “The path will be created if it doesn’t exist.”, _
                     “Save Message”, “C:Outlook Message Backup”)
    CreateFolders fPath

    If olItem.Sender Like “*@gmayor.com” Then    ‘Your domain
        fname = Format(olItem.SentOn, “yyyymmdd”) & Chr(32) & _
                Format(olItem.SentOn, “HH.MM”) & Chr(32) & olItem.SenderName & ” – ” & olItem.subject
    Else
        fname = Format(olItem.ReceivedTime, “yyyymmdd”) & Chr(32) & _
                Format(olItem.ReceivedTime, “HH.MM”) & Chr(32) & olItem.SenderName & ” – ” & olItem.subject
    End If
    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

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 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:
    Exit Function
End Function

Reply | Quote