Results 1 to 2 of 2

Thread: Macro to save emails to file

  1. #1
    VBAX Newbie
    Feb 2021

    Question Macro to save emails to file


    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

  2. #2
    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 - - 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
        Exit Sub
    End Sub
    Public Sub SaveItem(olItem As MailItem)
    'Graham Mayor - - 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 "*" 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
            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
        Exit Sub
        WriteToLog strPath & "Error Log.txt", strPath & fname
        GoTo lbl_Exit
    End Sub
    Private Function CreateFolders(strPath As String)
    'An Office macro by Graham Mayor -
    '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
        Set oFSO = Nothing
        Exit Function
    End Function
    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String)
    'Graham Mayor - - 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
        'oItem.SaveAs strPath & strFileName & ".txt", olTXT ' save as text
        oItem.SaveAs strPath & strFileName & ".msg", olMsg 'save as msg format
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts