Option Explicit
 Sub CopyToExcel()
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String

 Dim currentExplorer As Explorer
 Dim Selection As Selection
 Dim olItem As Outlook.MailItem
 Dim obj As Object
 Dim strColA, strColB, strColC, strColD, strColE As String
               
' Get Excel set up
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     
'## Open a specific workbook to input the data
'the path of the workbook under the windows user account
'enviro = CStr(Environ("USERPROFILE"))
' strPath = enviro & "\Documents\test.xlsx"
'     Set xlWB = xlApp.Workbooks.Open(strPath)
'     Set xlSheet = xlWB.Sheets("Sheet1")
'## End Specific workbook

'## Use New Workbook
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Sheet1")
'## end use new workbook

' Add column names
  xlSheet.Range("A1") = "Sender"
  xlSheet.Range("B1") = "Sender address"
  xlSheet.Range("C1") = "Message Body"
  xlSheet.Range("D1") = "Sent To"
  xlSheet.Range("E1") = "Recieved Time"

' Process the message record
    
  On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
  For Each obj In Selection

    Set olItem = obj
    
 'collect the fields
    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    strColC = olItem.Body
    strColD = olItem.To
    strColE = olItem.ReceivedTime
    
'### Get all recipient addresses
' instead of To names
Dim strRecipients As String
Dim strRecip As String
Dim Recipient As Outlook.Recipient
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList


For Each Recipient In olItem.Recipients

'### Get the Exchange address
' if not using Exchange, this block can be removed

If InStr(1, Recipient.Address, "/") > 0 Then
' if exchange, get smtp address
    Select Case Recipient.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = Recipient.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strRecip = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = Recipient.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strRecip = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = Recipient.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strRecip = olEU.PrimarySmtpAddress
         End If
     End Select
Else

strRecip = Recipient.Address

End If

' ### End Exchange section


 strRecipients = strRecip & "; " & strRecipients
 Next Recipient

  strColD = strRecipients
  strRecipients = ""
'### end all recipients addresses

'### Get the Exchange address
' if not using Exchange, this block can be removed
' Dim olEU As Outlook.ExchangeUser
' Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColB)

If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
    Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' ### End Exchange section




'write them in the excel sheet
  xlSheet.Range("A" & rCount) = strColA ' sender name
  xlSheet.Range("B" & rCount) = strColB ' sender address
  xlSheet.Range("C" & rCount) = strColC ' message body
  xlSheet.Range("D" & rCount) = strColD ' sent to
  xlSheet.Range("E" & rCount) = strColE ' recieved time
'Next row
  rCount = rCount + 1

' size the cells
    xlSheet.Columns("A:E").EntireColumn.AutoFit
    xlSheet.Columns("C:C").ColumnWidth = 100
    xlSheet.Columns("D:D").ColumnWidth = 30
    xlSheet.Range("A2").Select
    xlSheet.Columns("A:E").VerticalAlignment = xlTop

 Next
 xlApp.Visible = True

' to save but not close
'xlWB.Save

' to save and close
'     xlWB.Close 1
'     If bXStarted Then
'         xlApp.Quit
'     End If
' end save and close
    
     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlSheet = Nothing
     Set xlWB = Nothing
     Set xlApp = Nothing
 End Sub