HTML Code:
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 oAL As Outlook.AddressList
Dim olAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD As String
enviro = CStr(Environ("USERPROFILE"))
'where to find excel sheet
strPath = enviro & "\Documents\EmailList.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'Where to transfer the info
Set xlWB = xlApp.workbooks.Open(strPath)
Set xlSheet = xlWB.sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(4000).Row
' where to find the information
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'extract the information
strColB = olItem.SenderName
strColC = olItem.SenderEmailAddress
strColD = olItem.Sender.GetExchangeUser.Alias
'Get the Exchange address
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.session.CreateRecipient(strColB)
If InStr(1, strColC, "/") > 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
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If
'write them in the excel sheet
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("C" & rCount) = strColC
xlSheet.Range("D" & rCount) = strColD
'Next row
rCount = rCount + 1
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing Set xlSheet = Nothing