Save Selected Emails with Excel file containing Sender, Subject, Day of Receipt, msg, & attachments

Youtube video:

In Visual Basic Editor, enable the below Tools — References:

Code:

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 & "\"
                zz = 1
''''''''''''''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
        
         If zz <> 1 Then
    MkDir strpath & iiii & "\"
    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

Dim dirCollection2 As Collection
    Set dirCollection2 = New Collection
    
    Dim dirCollection3 As Collection
    Set dirCollection3 = New Collection
    
    Dim dirCollection4 As Collection
    Set dirCollection4 = 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)
          dirCollection2.Add (individualitem.SenderName)
          dirCollection3.Add (individualitem.ReceivedTime)
          dirCollection4.Add (individualitem.Subject)
        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









Dim ExcelSheet As Object
Set ExcelSheet = CreateObject("Excel.Sheet")
ExcelSheet.Application.Visible = True
ExcelSheet.Application.Cells(1, 1).Value = (dirCollection2(xy))
ExcelSheet.Application.Cells(1, 2).Value = (dirCollection3(xy))
ExcelSheet.Application.Cells(1, 3).Value = (dirCollection4(xy))

Range("D1").Select
ActiveCell.FormulaR1C1 = "=DAY(RC[-2])"
Range("E1").Select
ActiveCell.FormulaR1C1 = "=MONTH(RC[-3])"
Range("F1").Select
ActiveCell.FormulaR1C1 = "=YEAR(RC[-4])"
Range("G1").Select
ActiveCell.FormulaR1C1 = "=DATE(RC[-1],RC[-2],RC[-3])"
Range("H1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-4]<10,CONCATENATE(""0"",RC[-4]),RC[-4])"
Range("I1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-4]<10,CONCATENATE(""0"",RC[-4]),RC[-4])"

Range("K1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2],""-"",RC[-3],""-"",RC[-5])"


Columns("D:K").Select
Selection.Copy
Columns("D:K").Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False

Columns("A:K").Select
    Columns("A:K").EntireColumn.AutoFit
ActiveWorkbook.SaveAs FileName:=strpath & dirCollection(xy) & "\" & dirCollection(xy) & ".xls", FileFormat:=xlExcel8, CreateBackup:=False
ActiveWorkbook.Close False


    Set ExcelSheet = Nothing
    
    xy = xy + 1
    
Loop

End Sub