Macro to save emails to file

[glem]

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

[gmayor]

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


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.

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