none
VBA code to extract senders email contact card detail to Outlook RRS feed

  • Question

  • Hi

    I've use the below code to extract email details from Outlook to Excel for a defined date range and a particular mailbox. I was wondering if possible as part of the code extracting the email addresses per each email, I could also extract the contact card details from the outlook properties for each email? I would need the title and department? Can anyone provide the code for this? I understand this would only pull internal email information.

    Option Explicit

     Sub CopyToExcel()
     Dim xlApp As Object
     Dim xlWb As Object
     Dim xlSheet As Object
     Dim rCount As Long
     Dim bXStarted As Boolean
     Dim strPath As String
     Dim mailItems As Outlook.Items
     Dim olItem As Outlook.MailItem
     Dim i As Long
     Dim cFolders As Collection
     Dim olFolder As Outlook.Folder
     Dim subFolder As Folder
     Dim iDays As Long: iDays = 7
     Dim strStartDate As String
     Dim strEndDate As String

         strPath = Environ("USERPROFILE") & "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx"

         strStartDate = InputBox("Enter the latest date", "Start Date", Format(Date, "Short Date"))
         If Not IsDate(strStartDate) Then
             If strStartDate = "" Then
                 MsgBox "No date selected, or user cancelled"
             Else
                 MsgBox strStartDate & " is invalid"
             End If
             GoTo lbl_Exit
         End If

         strEndDate = InputBox("Enter the earliest date", "End Date", Format(Date - iDays, "Short Date"))
         If Not IsDate(strEndDate) Then
             If strEndDate = "" Then
                 MsgBox "No date selected, or user cancelled"
             Else
                 MsgBox strEndDate & " is invalid"
             End If
             GoTo lbl_Exit
         End If

         On Error Resume Next
         Set xlApp = GetObject(, "Excel.Application")
         If Err <> 0 Then
             Set xlApp = CreateObject("Excel.Application")
             bXStarted = True
         End If
         On Error GoTo 0

         Set xlWb = xlApp.Workbooks.Add
         xlApp.Visible = True
         Set xlSheet = xlWb.Sheets("Sheet1")
         xlSheet.Name = "Raw Data"

         xlSheet.Range("A" & 1) = "Sender Name"
         'xlSheet.Range("B" & 1) = "Creation Time"
         xlSheet.Range("B" & 1) = "Sent To"
         'xlSheet.Range("D" & 1) = "Recipients"
         'xlSheet.Range("E" & 1) = "Received By Name"
         xlSheet.Range("C" & 1) = "Sent On"
         'xlSheet.Range("G" & 1) = "Received Time"
         xlSheet.Range("D" & 1) = "subject"
         'xlSheet.Range("I" & 1) = "index"
         xlSheet.Range("E" & 1) = "Conversation"
         xlSheet.Range("F" & 1) = "Categories"
         xlSheet.Range("G" & 1) = "Folder"

         On Error Resume Next
         rCount = 2

         Set cFolders = New Collection
         cFolders.Add Session.PickFolder
         Do While cFolders.Count > 0
             Set olFolder = cFolders(1)
             Set mailItems = olFolder.Items
             mailItems.Sort "[SentOn]", True
             cFolders.Remove 1
             For i = 1 To mailItems.Count
                 Set olItem = mailItems(i)
                 If Not olItem Is Nothing Then
                     If Format(olItem.ReceivedTime, "yyyymmdd") <= _
                        Format(CDate(strStartDate), "yyyymmdd") And _
                        Format(olItem.ReceivedTime, "yyyymmdd") >= _
                        Format(CDate(strEndDate), "yyyymmdd") Then

                         With olItem
                             xlSheet.Range("A" & rCount) = .SenderName
                             'xlSheet.Range("B" & rCount) = .CreationTime
                             xlSheet.Range("B" & rCount) = .To
                             'xlSheet.Range("D" & rCount) = .Recipients
                             'xlSheet.Range("E" & rCount) = .ReceivedByName
                             xlSheet.Range("C" & rCount) = .SentOn
                             'xlSheet.Range("G" & rCount) = .ReceivedTime
                             xlSheet.Range("D" & rCount) = .Subject
                             'xlSheet.Range("I" & rCount) = .ConversationIndex
                             xlSheet.Range("E" & rCount) = .ConversationTopic
                             xlSheet.Range("F" & rCount) = .Categories
                             xlSheet.Range("G" & rCount) = olFolder.FolderPath
                         End With
                         rCount = rCount + 1
                    ElseIf Format(olItem.ReceivedTime, "yyyymmdd") <= _
                           Format(CDate(strEndDate), "yyyymmdd") Then
          Exit For
                     End If
                 End If
                 DoEvents
             Next i
             For Each subFolder In olFolder.Folders
                 cFolders.Add subFolder
             Next subFolder
         Loop

         xlWb.SaveAs strPath

         xlWb.Close 1
         If bXStarted Then
             xlApp.Quit
         End If
         MsgBox ("All RM Group Emails exported to Excel..........")
    lbl_Exit:
         Set olItem = Nothing
         Set xlApp = Nothing
         Set xlWb = Nothing
         Set xlSheet = Nothing
         Set mailItems = Nothing
         Set olFolder = Nothing
         Exit Sub
     End Sub

    Thanks,

    Ed


    • Edited by Ed McArdle Saturday, September 24, 2016 11:58 AM
    Saturday, September 24, 2016 11:56 AM

All replies

  • Hi Ed McArdle,

    you had asked,". I was wondering if possible as part of the code extracting the email addresses per each email,"

    To get the Email Address you just need to add the below mentioned line in your code where you assign the data to Excel column.

    xlSheet.Range("H" & rCount) = .Sender.Address

    it will add a column for Email Address.

    you can mention the which details exactly want from a contact card so that we can try to guide you regarding that.

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Monday, September 26, 2016 8:28 AM
    Moderator
  • Thanks for coming back,

    Exact details are the below:

    Right click on email address and select Outlook Properties. Within the contact card details I would like to extract "Title" and "Department" fields.

    Do you know if this is possible to extract?

    Thanks,

    Ed

    Monday, September 26, 2016 11:58 AM
  • I tried adding the below but it didn't work for me,

                             xlSheet.Range("H" & rCount) = olExchgnUser.JobTitle
                             xlSheet.Range("I" & rCount) = olExchgnUser.Department

    thanks,

    ed

    Monday, September 26, 2016 1:07 PM
  • Hi Ed McArdle,

    you can use the code mentioned below to access Job Title and Department.

    Sub ReadRecpDetail()
    
    'Declarations
    
    Dim myOlApp As Outlook.Application
    
    Dim myItem As Outlook.MailItem
    
    Dim myRecipient As Outlook.Recipient
    
     
    
    Set myOlApp = CreateObject("Outlook.Application")
    
    Set myItem = myOlApp.CreateItem(olMailItem)
    
     
    
    'add some recipient
    
    Set myRecipient = myItem.Recipients.Add("put the mail address here from your outlook")
    
     
    
    'read one of the details of reipient
    
    Debug.Print ("Job Title: " & myRecipient.AddressEntry.GetExchangeUser.JobTitle)
    
    Debug.Print ("Alias Name: " & myRecipient.AddressEntry.GetExchangeUser.Alias)
    
    Debug.Print ("Department Name: " & myRecipient.AddressEntry.GetExchangeUser.Department)
    
    Debug.Print ("User Name: " & myRecipient.AddressEntry.GetExchangeUser.Name)
    
    Debug.Print ("Address: " & myRecipient.AddressEntry.GetExchangeUser.Address)
    
    Debug.Print ("City:" & myRecipient.AddressEntry.GetExchangeUser.City)
    
     
    
    'open up the e-mail message [optional]
    
    myItem.Display
    
     
    
    End Sub
    

    There are also some other extra details mentioned in the macro that you can try to use based upon your needs.

    the result will be displayed in the immediate window.

    you can modify the code to export this details to Excel.

    Regards

    Deepak 


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Tuesday, September 27, 2016 3:30 AM
    Moderator
  • Thanks Deepak,

    do you know how I can take the above and input into my existing code? sorry my vba knowledge is limited to some extent.

    regards,

    ed.

    Tuesday, September 27, 2016 8:01 AM
  • Hi Ed McArdle,

    we are accessing the Recipients details from Outlook.Recipient.

    so if you merge that in your code that also it will not get match to the data printed by your sub.

    so here I suggest you to access it individually.

    Regards

    Deepak 


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Thursday, October 6, 2016 5:52 AM
    Moderator