Solved

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

Posted on 2016-08-28
21
50 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
  • 12
  • 9
21 Comments
 

Author Comment

by:rayluvs
Comment Utility
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 25

Accepted Solution

by:
ProfessorJimJam earned 500 total points
Comment Utility
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
Comment Utility
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
 
LVL 25

Expert Comment

by:ProfessorJimJam
Comment Utility
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
Comment Utility
Thanx!!!!

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

Expert Comment

by:ProfessorJimJam
Comment Utility
you are welcome.
0
 

Author Comment

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

olvbaerr
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
Comment Utility
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
Comment Utility
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 25

Expert Comment

by:ProfessorJimJam
Comment Utility
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
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 

Author Comment

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

Author Comment

by:rayluvs
Comment Utility
the objSender doesn't present any value...


olvba2
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Nevertheless, you have helped us super!  We will proceed to close the question!
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
Comment Utility
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 25

Expert Comment

by:ProfessorJimJam
Comment Utility
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
Comment Utility
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 25

Expert Comment

by:ProfessorJimJam
Comment Utility
You are welcome thanks for the feedback
0

Featured Post

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Suggested Solutions

Create high volume marketing opportunities using email signatures with these top 10 DOs and DON'Ts of email signature marketing.
Resolve DNS query failed errors for Exchange
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
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…

772 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

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now