Save Custom Email and Folder Name with Attachments VBA

Video below:

Code in Outlook:

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

Dim i As Double
Dim ii As Double
Dim iii As Double
Dim iiii As Double

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

 i = myOlSel.Count
 iii = 1
 iiii = 1



 
 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
 
 
 '''''''''''''SELECT PATH AREA
   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
 
  '''''''''''''END SELECT PATH AREA

   
    
   
 
 'if you want to include any attachments while saving the email too
 
  If myOlSel.Item(x).Class = OlObjectClass.olMail Then
 
     Set dicFileNames = CreateObject("Scripting.Dictionary")
    
    
      'For x = 1 To myOlSel.Count 'new
 
 '''''''''''''Save attachments
    
    For Each individualitem In Application.ActiveExplorer.Selection
        If TypeName(individualitem) = "MailItem" Then
            For Each att In individualitem.Attachments
            
            
             ii = individualitem.Attachments.Count 'newem
             
             
                If Not dicFileNames.exists(att.FileName) Then
                dicFileNames.Add att.FileName, 1
                Else
                dicFileNames(att.FileName) = dicFileNames(att.FileName) + 1
                dicFileNames.Add att.FileName & iiii & iii, iii
                End If
                
                   If iii = 1 Then

''''''''''''''MAKE FOLDER BASED on Path SELECTION if new iteration
                MkDir strpath & iiii & "\"
''''''''''''''END FOLDER BASED on Path SELECTION
                End If
                
                  iii = iii + 1
                
               att.SaveAsFile strpath & iiii & "\" & "Attachment " & iii - 1 & "_" & att.FileName
        '''''''''''''Attachment saved from this email      
            Next att
        End If
        
           iii = 1
    iiii = iiii + 1

'''''''''test if count of iteration of emails > selection count/leave Loop

    If iiii > i Then
    GoTo ending:
    End If
        
        
   ''''NEXT Selected email/save attachments if didn't exit loop   
    Next individualitem
 
 
End If
ending:
iiii = 1

'''''''''''''''*************************
'''create a collection to add each email name/folder name as variable emailname
  Dim dirCollection As Collection
    Set dirCollection = New Collection

''''''''''''''''''''''''''*******************



 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 & iiii & "\" & emailname & ".msg"
          iiii = iiii + 1
          dirCollection.Add (emailname)
        End If
    Next individualitem

 End If
 
 'rename folders;
 


'count the number of files in a folder (ignore - I have this commented out)
'Dim folderpath As String, path As String, count As Integer
'folderpath = "C:\Users\18622\OneDrive\Desktop\New folder\"
'Filename = Dir(folderpath)
'Do While Filename <> ""
'count = count + 1
'Filename = Dir()
'Loop
'MsgBox count

Dim xx As Double

 Dim oFSO As Object
 Dim folder As Object
 Dim subfolders As Object
 
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 Set folder = oFSO.GetFolder(strpath)
 Set subfolders = folder.subfolders
 xx = subfolders.Count
 
 Set oFSO = Nothing
 Set folder = Nothing
 Set subfolders = Nothing
 'release memory

Dim strOldDirName As String
Dim strNewDirName As String
Dim xy As Double

xy = 1


'''''''''''''''*************************

''''''''''''''''''''''''''*******************

Dim foldername As String

Do Until xy > dirCollection.Count
foldername = dirCollection(xy)
strOldDirName = strpath & xy & "\"

strNewDirName = strpath & dirCollection(xy) & "\"

Name strOldDirName As strNewDirName


xy = xy + 1
Loop

'if you want the subject
'dirCollection2.Add (individualitem.Subject)
'if you want the sendername
 'dirCollection2.Add (individualitem.SenderName)
'if you want the reeceived date/time
'dirCollection2.Add (individualitem.ReceivedTime)
'press CONTROL + space after the individualitem. for the methods
' tools - options show Tooltips for viewing the tooltip during execution
'if you hover over a variable
end sub