How to get the exact Outlook email senders address instead 'FIRST ADMINISTRATIVE GROUP' via VBA

FYI:
(code if necessary for helping us)

The problem is in line xlSheet.Range("B" & rCount) = strColB 'SenderEmailAddress

Sub aaaCopyToExcel()
  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 strColB, strColC, strColD, strColE, strColF As String
 'Start
  xVar = 0
 'Get Excel set up
  enviro = CStr(Environ("USERPROFILE"))
 'the path of the workbook
  strPath = enviro & "\Documents\test.xlsx"
  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 the workbook to input the data
  Set xlWB = xlApp.Workbooks.Open(strPath)
  Set xlSheet = xlWB.Sheets("Sheet1")
 
 'Process the message record
  On Error Resume Next
 
 'Find the next empty line of the worksheet
  rCount = xlSheet.Range("B" & 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
     'Get Outlook fields
      strColB = olItem.SenderEmailAddress
      strColC = olItem.To
      strColD = olItem.Subject
      strColE = olItem.ReceivedTime
      strColF = olItem.Body
     'Write Outlook field to excel
      xlSheet.Range("B" & rCount) = strColB 'SenderEmailAddress
      xlSheet.Range("c" & rCount) = strColC 'To
      xlSheet.Range("d" & rCount) = strColD 'Subject
      xlSheet.Range("e" & rCount) = strColE 'ReceivedTime
      xlSheet.Range("f" & rCount) = strColF 'Body
      xVar = xVar + 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
 End Sub

Select allOpen in new window

You are correct, sorry about that.

Noticed the changes the the for/each lines, etc., can u gives a us bit of explaining? (Just for our understanding of what u did)

Thanx.

on the original code from your previous post,


i modified only  by replacing the line

strColB = olItem.SenderEmailAddress

Select allOpen in new window

 with the below code

If olItem.SenderEmailType = "SMTP" Then
  strColB = olItem.SenderEmailAddress
Else
  'read PidTagSenderSmtpAddress
  strColB = olItem.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
  If Len(strColB) = 0 Then
    Set objSender = olItem.Sender
    If Not (objSender Is Nothing) Then
      'read PR_SMTP_ADDRESS_W
      strColB = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
      If Len(strColB) = 0 Then
        'last resort
        Set exUser = objSender.GetExchangeUser
        If Not (exUser Is Nothing) Then
          strColB = exUser.PrimarySmtpAddress
        End If
      End If
    End If
  End If
End If

Select allOpen in new window

SMTP address can be accessed in different property and it can be access via different methods, of which one will will be using olItem.PropertyAccessor you can read about it in Microsoft page

Thanx!!!!

We'll proceed incorporate the changes!!!
(will keep you informed)

you are welcome.

We are getting an error on "Set objSender = olItem.sender" (your line #7), we have to declare it as what type?

you are in break mode, meaning that you have run the dubugger and it is highlighting yellow.

reset the code and run again.  

see the screenshot.

It just appear after selecting the macro to run, we didn't run the debugger.  Does objSender has to be declared? (we don't see it declare anywhere in the code)

rayluvs,

the reason it worked in my machine and not yours, is probably because your have the Option Explicit before the code that makes the declarations mandatory to be declared.

so you should declare the following items as outlook.mailitem

  Dim objSender As Outlook.MailItem
  Dim exUser As Outlook.MailItem

the full complete code.

Option Explicit

Sub aaaCopyToExcel()
  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 objSender As Outlook.MailItem
  Dim exUser As Outlook.MailItem
  Dim strColB, strColC, strColD, strColE, strColF As String
 'Start

 'Get Excel set up
  enviro = CStr(Environ("USERPROFILE"))
 'the path of the workbook
  strPath = enviro & "\Documents\test.xlsx"
  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 the workbook to input the data
  Set xlWB = xlApp.Workbooks.Open(strPath)
  Set xlSheet = xlWB.Sheets("Sheet1")
 
 'Process the message record
  On Error Resume Next
 
 'Find the next empty line of the worksheet
  rCount = xlSheet.Range("B" & 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
     'Get Outlook fields
      On Error Resume Next 'PropertyAccessor can raise an exception if a property is not found
If olItem.SenderEmailType = "SMTP" Then
  strColB = olItem.SenderEmailAddress
Else
  'read PidTagSenderSmtpAddress
  strColB = olItem.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
  If Len(strColB) = 0 Then
    Set objSender = olItem.Sender
    If Not (objSender Is Nothing) Then
      'read PR_SMTP_ADDRESS_W
      strColB = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
      If Len(strColB) = 0 Then
        'last resort
        Set exUser = objSender.GetExchangeUser
        If Not (exUser Is Nothing) Then
          strColB = exUser.PrimarySmtpAddress
        End If
      End If
    End If
  End If
End If

      strColC = olItem.To
      strColD = olItem.Subject
      strColE = olItem.ReceivedTime
      strColF = olItem.Body
     'Write Outlook field to excel
      xlSheet.Range("B" & rCount) = strColB 'SenderEmailAddress
      xlSheet.Range("c" & rCount) = strColC 'To
      xlSheet.Range("d" & rCount) = strColD 'Subject
      xlSheet.Range("e" & rCount) = strColE 'ReceivedTime
      xlSheet.Range("f" & rCount) = strColF 'Body
      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
 End Sub

Select allOpen in new window

u r correct 'option explicit' is set... ok will proceed.

the objSender doesn't present any value...

Are you tying running the debugger with stepping though the code?

the latest code I provided works perfectly and I tested it . Select couple of emails in outlook then run the code .plz run the whole code not via debugger stepping. It will then export those selected emails into the excel file test which is in your document folder .

We ran without the debugger and the variable "strColB" for olItem.SenderEmailAddress didnt show in the excel; that column went empty.

We then went again with debugger to see what happen and noticed that the variable is "empty"

Ok, we'll try on other emails.

Worked excellently in our regular emails, but in a specific PST it doesn't display the emails; the column is empty.

Ok found the problem.  Within the outlook list the emails seems ok, but when we open the email, the "from" is ether empty or it says "user@domain.com" where domain.com is the actual domain name.

Maybe this is the problem.

Nevertheless, you have helped us super!  We will proceed to close the question!

Rayluvs,

The code has multiple sets of condition, it checks for different type of from if one set of condition is empty meaning as you pointed has no value =nothing , then it will picked by the second condition which is the getexchnageuser . So, the code should export all of the selected emails from outlook and I am sure it does that. Unless you are telling me that you run the code on outlook and selected emails were not exported to the exce file, plz do let me know if this is the case, which is unlikely to be the case.

I just read your comment l, if you are opening emails from PST where there is no actual email in from
Field then there is nothing to return because there isn't any email there

Yes, couldn't have said better; exactly what we meant.  Nevertheless the code works excellence!  

The purpose of our entry in 41779053 is because your code helped us literally really looked at the PST and that made found the error: it was not code, it was data.

Again, thanx lots!!! We will proceed to close the question.

You are welcome thanks for the feedback