[Webinar] Streamline your web hosting managementRegister Today

x
?
Solved

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

Posted on 2016-08-28
21
Medium Priority
?
182 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
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 27

Accepted Solution

by:
ProfessorJimJam earned 2000 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
Free tool for managing users' photos in Office 365

Easily upload multiple users’ photos to Office 365. Manage them with an intuitive GUI and use handy built-in cropping and resizing options. Link photos with users based on Azure AD attributes. Free tool!

 
LVL 27

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 27

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 27

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 27

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 27

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 27

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 27

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 27

Expert Comment

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

Featured Post

Easily manage email signatures in Office 365

Managing email signatures in Office 365 can be a challenging task if you don't have the right tool. CodeTwo Email Signatures for Office 365 will help you implement a unified email signature look, no matter what email client is used by users. Test it for free!

Question has a verified solution.

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

Mailbox Corruption is a nightmare every Exchange DBA wishes he never has. Recovering from it can be super-hectic if not entirely futile. And though techniques like the New-MailboxRepairRequest cmdlet have been designed to help with fixing minor corr…
Check out the easy way to Export Thunderbird to MS Outlook. It can be done effectively by using manual method and if you are not much into coding then you can definitely try the third party tool for the conversion.
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…
There may be issues when you are trying to access Outlook or send & receive emails or due to Outlook crash which leads to corrupt or damaged PST file. To eliminate the corruption from your PST file, you need to repair the corrupt Outlook PST file. U…

591 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