Save Selected Emails with Custom Name VBA Outlook – Avoid Too Long Email Names

The below code lets you select the name for an email before saving it.

Make sure that you have the below enabled in Tools — References in your Outlook VBE:

Code:

Sub GetSelectedItems()
 Dim myOlExp As Outlook.Explorer
 Dim myOlSel As Outlook.Selection
 Dim individualitem As Outlook.MailItem


 Dim MsgTxt As String
 Dim x As Long
 'Get senders of selected emails
x = 1
 Set myOlExp = Application.ActiveExplorer
 Set myOlSel = myOlExp.Selection



 
 If myOlSel.Item(x).Class = OlObjectClass.olMail Then
 ' For mail item, use the SenderName property.
 'set the path for where the attachments will be saved
 
 
 
   Dim xlObj As Excel.Application
    Dim fd As Office.FileDialog

    Set xlObj = New Excel.Application
    xlObj.Visible = False
    Set fd = xlObj.Application.FileDialog(msoFileDialogFolderPicker)
    With fd
         .Filters.Clear
    .Title = "Choose a Folder path"
    .AllowMultiSelect = False
       
         .InitialFileName = "C:\Users\18622\OneDrive\Desktop\VBA Lessons\Funds\"
    
            If .Show = True Then
 
        strpath = .SelectedItems(1) & "\"
        End If
        
    End With
    xlObj.Quit
    Set xlObj = Nothing
 
 
 
 
    'Alternatively, you can use Userforms or set a static path.... strpath = "C:\Users\18622\OneDrive\Desktop\VBA Lessons\Funds\Fund 1\"
    
    Set dicFileNames = CreateObject("Scripting.Dictionary")
    
    For Each individualitem In Application.ActiveExplorer.Selection

        If TypeName(individualitem) = "MailItem" Then
        emailname = InputBox("Set name for email")
          individualitem.SaveAs strpath & emailname & ".msg"
        End If
    Next individualitem

 End If

 Debug.Print MsgTxt
End Sub