Public Sub CopyMailtoExcel()
    Dim objOL As Outlook.Application
    Dim objFolder As Outlook.Folder
    Dim objItems As Outlook.Items
    Dim olItem As Object ' MailItem
    Dim strDisplayName, strAttCount, strBody, strDeleted As String
    Dim strReceived As Date
    Dim rCount As Long
    
'  On Error GoTo Err_Execute
    Application.ScreenUpdating = False
 
'Find the next empty line of the worksheet
rCount = Range("A" & Rows.Count).End(-4162).Row
rCount = rCount + 1

Set objOL = Outlook.Application
    
' copy mail to excel
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
  
For Each olItem In objItems
strAttCount = ""
strBody = ""

If olItem.attachments.Count > 0 Then strAttCount = "Yes"

'On Error Resume Next
 'collect the fields
strBody = olItem.Body
    
' Remove this block if you don't want to remove the hyperlinked urls
Dim Reg1 As RegExp
Dim Match, Matches
Set Reg1 = New RegExp

' remove hyperlinks from bodies for easier reading. 
With Reg1
        .Pattern = "<[src|http|mailto](.*)>(\s)*"
        .Global = True
        .IgnoreCase = True
    
.MultiLine = True

End With
    
If Reg1.test(strBody) Then
 strBody = Reg1.Replace(strBody, "")
End If
' end remove hyperlinks block 
   
               
strBody = Trim(strBody)
strReceived = olItem.ReceivedTime
strSender = olItem.SenderName

' column / field
' A Date
' B Time
' C Attachments (Yes)
' D Subject
' E Body
' F From (display name)
' G To (display name)
' H CC (display name)
' I BCC (sent items only)

'write them in the excel sheet
 Range("A" & rCount) = strReceived ' format using short date
 Range("B" & rCount) = strReceived 'format using time
 Range("C" & rCount) = strAttCount
 Range("D" & rCount) = olItem.Subject
 Range("E" & rCount) = strBody
 Range("F" & rCount) = strSender
 Range("G" & rCount) = olItem.To
 Range("H" & rCount) = olItem.CC
 Range("I" & rCount) = olItem.BCC
 

'Next row
  rCount = rCount + 1
  Next


' Basic Formatting
Columns("A:I").Select
With Selection
    .WrapText = True
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlTop
    .Columns.AutoFit
End With
Columns("E:E").Select ' body column
With Selection
    .ColumnWidth = 200
    .Rows.AutoFit
End With

Columns("A:A").Select
Selection.NumberFormat = "[$-409]ddd mm/dd/yy;@"
Range("B:B").Select
Selection.NumberFormat = "[$-F400]h:mm AM/PM"

Range("A1").Select

Application.ScreenUpdating = True
Set olItem = Nothing
Set objFolder = Nothing
Set objOL = Nothing
Set Reg1 = Nothing

MsgBox "Email import complete"

Exit Sub
    
Err_Execute:
    MsgBox "An error occurred."
    
End Sub