VBA Script that gets list of all Outlook Emails in the Currently Selected Folder

Option Explicit

' VBA Script to get list of All Emails IN CURRENTLY SELECTED FOLDER
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Programming by Greg Thatcher, http://www.GregThatcher.com

Public Sub GetListOfEmails()
    On Error GoTo On_Error
    
    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim Folder As Outlook.Folder
    
    Set Session = Application.Session
        
    Set Folder = Application.ActiveExplorer.CurrentFolder
    
    Call GetAllEmailsInFolder(Folder, Report)
    
    Dim retValue As Boolean
    retValue = CreateReportAsEmail("List of Emails", Report)
    
Exiting:
        Set Session = Nothing
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub


Private Sub GetAllEmailsInFolder(CurrentFolder As Outlook.Folder, Report As String)
    Dim CurrentItem
    
    Report = Report & "Folder Name: " & CurrentFolder.Name & " (Store: " & CurrentFolder.Store.DisplayName & ")" & vbCrLf
    

    For Each CurrentItem In CurrentFolder.Items
        Report = Report & CurrentItem.Subject
        Report = Report & vbCrLf
        Report = Report & CurrentItem.Body
        Report = Report & vbCrLf
        Report = Report & "----------------------------------------------------------------------------------------"
        Report = Report & vbCrLf
    Next
    
End Sub

' VBA Function which displays a report inside an email
Public Function CreateReportAsEmail(Title As String, Report As String)
    On Error GoTo On_Error
    
    Dim Session As Outlook.NameSpace
    Dim mail As MailItem
    Dim MyAddress As AddressEntry
    Dim Inbox As Outlook.Folder
    
    CreateReportAsEmail = True
    
    Set Session = Application.Session
    Set Inbox = Session.GetDefaultFolder(olFolderInbox)
    Set mail = Inbox.Items.Add("IPM.Mail")
    
    Set MyAddress = Session.CurrentUser.AddressEntry
    mail.Recipients.Add (MyAddress.Address)
    mail.Recipients.ResolveAll
    
    mail.Subject = Title
    mail.Body = Report
    
    mail.Save
    mail.Display
    
    
Exiting:
        Set Session = Nothing
        Exit Function
On_Error:
    CreateReportAsEmail = False
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Function