Macro to save emails to file

Hello,

I'm quite verse in Excel VBA but never created a Macro in Outlook. I want to create a macro that would help/simplify saving emails to account folder. More specifically, I want the macro to do the following: when sending an email, a pup-up would appear asking if the email should be saved to account file, if the answer is no, the email gets sent as normal, if the answer is yes, the user can enter/select the directory and name to allocate to the file .msg and automatically saved the email to the correct location and name. In addition, I want a second macro that can be actioned by the user to save emails received. When actioning, the user would have to enter/select the directory and allocate a name for the .msg file. I would appreciate any guidance/direction to help me get to this.

Thank you

The two requirements require different approaches. For the sent items you need to create an event in the ThisOutlookSession module e.g.

Code:

---

Option Explicit

Public WithEvents olItems As Outlook.items


Public Sub Application_Startup()
Dim olNS As Outlook.NameSpace
    Set olNS = Application.GetNamespace("MAPI")
    Set olItems = olNS.GetDefaultFolder(olFolderSentMail).items
    Exit Sub
End Sub


Private Sub olItems_ItemAdd(ByVal Item As Object)
'Graham Mayor - https://www.gmayor.com - Last updated - 15 Feb 2021
Dim sPrompt As String
Dim olFolder As Outlook.Folder
    If TypeName(Item) = "MailItem" Then
        On Error Resume Next
        sPrompt = "Do you want to file the following message?" & vbCr & Item.Subject
        If MsgBox(sPrompt, vbYesNo, "File message?") = vbYes Then
            SaveItem Item
        End If
    End If
    Exit Sub
End Sub

---

This event is created when Outlook is started (or you can run Application_Startup directly). It calls the SaveItem macro (below) when you agree to the prompt.
The following is created in a standard module and the main code can be called from a rule that runs the script when appropriate messages are received. There's a test option so that you can try it out with messages in your inbox to adjust the prompts and the folders etc as required. This module code I have posted several times previously.

Code:

---

Option Explicit
Private Const strPath As String = "C:\Outlook Message Backup\" 'The root folder where the message subfolders are located


Sub TestSaveMessage()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveItem olMsg
lbl_Exit:
    Exit Sub
End Sub


Public Sub SaveItem(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 10 Jun 2020
'May be used as a script with an Outlook rule
Dim fname As String, strFolder As String


    strFolder = strPath
    strFolder = strFolder & InputBox("Name of client", olItem.Subject)
   


    If olItem.SenderEmailAddress Like "*@gmayor.com" Then    'Your email address
        strFolder = strFolder & "_Sent Items\"
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        strFolder = strFolder & "_Received Items\"
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    End If
    CreateFolders strFolder


    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(92), "-")
    fname = Replace(fname, Chr(124), "-")
    On Error GoTo err_Handler
    SaveUnique olItem, strFolder, fname
lbl_Exit:
    Exit Sub
err_Handler:
    WriteToLog strPath & "Error Log.txt", strPath & fname
    Err.Clear
    GoTo lbl_Exit
End Sub


Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
'Creates the full path 'strPath' if missing or incomplete
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)
'Graham Mayor - http://www.gmayor.com - Last updated - 29/03/2017
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim FSO As Object
    CreateFolders strPath
    Set FSO = CreateObject("Scripting.FileSystemObject")
    lngF = 1
    lngName = Len(strFileName)
    Do While FSO.FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    'oItem.SaveAs strPath & strFileName & ".txt", olTXT ' save as text
    oItem.SaveAs strPath & strFileName & ".msg", olMsg 'save as msg format
lbl_Exit:
    Exit Function
End Function

---