Solved

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

Posted on 2016-08-28
21
110 Views
Last Modified: 2016-09-05
We are using Outlook 2010 and via VBA script trying to extract the exact emails from a series of PST we need to get info from.

The code works well when using it on some PST it exports the following as the sender email:

                               /O=DOMAIN/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN="sender-name"

                               when is should mbe

                               sender-name@domainname.com

Note: this happens to only some PST, not all.

We want the code to export exactly the sender's email used.

Please advice.
0
Comment
Question by:rayluvs
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 12
  • 9
21 Comments
 

Author Comment

by:rayluvs
ID: 41773656
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

Open in new window

0
 
LVL 26

Accepted Solution

by:
ProfessorJimJam earned 500 total points
ID: 41774419
although, the code posted above was not the updated and corrected code as per solution i provided  in post

here is the correct and modified complete code that takes care of the above mentioned issue of SMTP address.

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

 '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

Open in new window

0
 

Author Comment

by:rayluvs
ID: 41774613
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.
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41774649
on the original code from your previous post,


i modified only  by replacing the line
strColB = olItem.SenderEmailAddress

Open 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

Open 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
0
 

Author Comment

by:rayluvs
ID: 41774693
Thanx!!!!

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

Expert Comment

by:ProfessorJimJam
ID: 41774719
you are welcome.
0
 

Author Comment

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

olvbaerr
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41778040
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.

2016-08-31-15_10_13-Microsoft-Visual.png
0
 

Author Comment

by:rayluvs
ID: 41778355
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)
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41778623
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

Open in new window

0
 

Author Comment

by:rayluvs
ID: 41778832
u r correct 'option explicit' is set... ok will proceed.
0
 

Author Comment

by:rayluvs
ID: 41778844
the objSender doesn't present any value...


olvba2
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41778855
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 .
0
 

Author Comment

by:rayluvs
ID: 41779036
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.
0
 

Author Comment

by:rayluvs
ID: 41779043
Worked excellently in our regular emails, but in a specific PST it doesn't display the emails; the column is empty.
0
 

Author Comment

by:rayluvs
ID: 41779050
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.
0
 

Author Comment

by:rayluvs
ID: 41779053
Nevertheless, you have helped us super!  We will proceed to close the question!
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41779256
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.
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41779261
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
0
 

Author Comment

by:rayluvs
ID: 41784683
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.
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41784923
You are welcome thanks for the feedback
0

Featured Post

Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
This article will help to fix the below error for MS Exchange server 2010 I. Out Of office not working II. Certificate error "name on the security certificate is invalid or does not match the name of the site" III. Make Internal URLs and External…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

688 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question