VBA : Extracting the Email body from outlook with user selected mailbox folders

Extracting the Email body from outlook with user selected mailbox folders.

Public Sub GetFromInbox()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItms As Outlook.Items
    Dim olMail As Variant
    Dim x As Long, y As Long
    Dim ResponseSheet As Worksheet
 
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
 
    ActiveSheet.AutoFilterMode = False
    '************ Getting Base data last row and column

    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFldr = olNS.PickFolder
    If olFldr = "Nothing" Then Exit Sub
    Set olItms = olFldr.Items
 
    olItms.Sort "RECEIVED", True
 
    For Each sht In ThisWorkbook.Sheets
        If sht.Name = "Responses" Then sht.Delete
    Next sht
    Set ResponseSheet = ThisWorkbook.Sheets.Add
    ActiveSheet.Name = "Responses"
 
    Cells(1, 1) = "Sender"
    Cells(1, 2) = "To"
    Cells(1, 3) = "CC"
    Cells(1, 4) = "Subject"
    Cells(1, 5) = "Body"
    Cells(1, 6) = "ReceivedTime"
 
    Dim i As Long
    i = 2
    For Each olMail In olItms
        On Error Resume Next
        Cells(i, 1) = olMail.Sender
        Cells(i, 2) = olMail.To
        Cells(i, 3) = olMail.CC
        Cells(i, 4) = WorksheetFunction.Substitute(WorksheetFunction.Substitute(olMail.Subject, "RE: ", ""), "FW: ", "")
        Cells(i, 5) = HtmlToText(olMail.HTMLBody)
        Cells(i, 6) = olMail.ReceivedTime
     
        i = i + 1


    Next olMail

    Set olFldr = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
End Sub