SubEmailAddress_From_Outlook_To_Excel()
'Clear Data Columns to Write Output
ThisWorkbook.Sheets(1).Columns(1).ClearContents
ThisWorkbook.Sheets(1).Columns(2).ClearContents
ThisWorkbook.Sheets(1).Columns(3).ClearContents
DimRecipList AsRecipients
Dimaddtype AsOlAddressEntryUserType
'Get Subject of Selected Email ID
On ErrorGoToFatal_Error:
ThisWorkbook.Sheets(1).Cells(1,1)=Outlook.ActiveExplorer.Selection.Item(1).Subject
MsgBox"You have Selected the Email with Subject: "&ThisWorkbook.Sheets(1).Cells(1,1)
ThisWorkbook.Sheets(1).Cells(2,1)="To"
'Get To, CC & BCC from a Outlook Email
SetRecipList=Outlook.ActiveExplorer.Selection.Item(1).Recipients
ThisWorkbook.Sheets(1).Cells(1,2)="Number Of Mail IDs: "&RecipList.Count
iRow=2
'Process Each Mail Contact
ForMailIdx=1ToRecipList.Count
'Check whether Contact already has a Mail ID
addtype=RecipList.Item(MailIdx).AddressEntry.AddressEntryUserType
Ifaddtype<>olExchangeUserAddressEntry Then
GoToError_Fetch_Next:
EndIf
'Get Mail Address
On ErrorGoToError_Fetch_Next:
ThisWorkbook.Sheets(1).Cells(MailIdx+2,1)=RecipList.Item(MailIdx).AddressEntry.GetExchangeUser.PrimarySmtpAddress
GoToProcess_Next_Contact
Error_Fetch_Next:
ThisWorkbook.Sheets(1).Cells(MailIdx+2,1)=RecipList.Item(MailIdx).Address
Ifaddtype=30Then
ThisWorkbook.Sheets(1).Cells(MailIdx+2,2)=""
Else
ThisWorkbook.Sheets(1).Cells(MailIdx+2,2)=addtype
EndIf
Process_Next_Contact:
Next
MsgBox"Process Completed"
ExitSub
Fatal_Error:
MsgBox"Fatal Error: Check Outlook is running & any Email is selected to Process"
EndSub