• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

retrieving data from mails(outlook) using excel/vba

W

webmax

Member
Hi,

I want to retrieving data from Mail from outlook using excel / vba

I have Inbox & Sent Items
I want the following data in excel

From
To
CC
Bcc
Subject
Body of the Message
 
Here's one way to do it. You need to paste this in the OutlookSession code module

Code: 
Const strFilePath As String = "C:\Users\Public\Documents\Excel\OutlookMailItemsDB.xlsx"
Const strSubjectLineStartWith As String = ""
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
   
    Dim varArray As Variant
    Dim strSub As String
    Dim strBody As String
    Dim strArray() As String
    Dim lngLoop As Long
    Dim objItem As Object
    Dim lngMailCounter As Long
    Dim objMItem As MailItem
    strArray = Split(EntryIDCollection, ",")
    For lngMailCounter = LBound(strArray) To UBound(strArray)
        Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
        If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
            Set objMItem = objItem
            With CreateObject("Excel.Application").workbooks.Open(strFilePath)
                With .sheets(1)
                    With .cells(.rows.Count, 1).End(-4162)(2).resize(1, 7)
                        .Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
                    End With
                End With
                .Close 1
            End With
            Set objItem = Nothing
        End If
    Next lngMailCounter
    If Not IsEmpty(strArray) Then
        Erase strArray
    End If
   
End Sub

In case you want to do this for only mails with certain subject, you can put that in the strSubjectLineStartWith variable. I've left this as "" as of now.
 
Hi sam,

When i run the macro in the outlook session it is not showing the macro name and not running.
 

Attachments

  • email.xlsx
    342.3 KB · Views: 103
webmax, the macro runs whenever there's a new mail coming to your inbox. you cannot just run it like calling any subroutine. I was under the impression that you are looking to capture data as and when you get mails in your outlook. Please clarify, and sorry for the confusion.
 
webmax, you need to put a file somewhere and update the link I gave in the code

Code: 
Const strFilePath As String = "C:\Users\Public\Documents\Excel\OutlookMailItemsDB.xlsx"
 
You can create any xlsx file, and save it anywhere on a folder that is accessible to you. Just replace the path I entered above with the entire path and file name of your file
 
thanks sam it is working fine.....
and also i need how to track the sent items and existing mail in inbox also
 
OK, this is part of a solution I gave to another user elsewhere. You will notice that there are a few additional information, over what you need to fetch from your inbox. Moreover, I've also given an option to Select any folder in your inbox.

You need to run this from the workbook where you are storing the information. In addition, you need to add the Microsoft Outlook X.0 Library in the VBE. In addition, you need to ensure that you've logged in to your Outlook mailbox before you run this macro. On top of that, I haven't tested this much, though I know it was working when I gave this solution in another forum. You might have to tweak it a little here and there, just to ensure you are getting what you need. For example, I'm getting 9 information from the mails, where as you only need 5.

Code: 
Sub ExportToExcelV2()
 
    Dim appExcel As Excel.Application
    Dim appOutlook As Outlook.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.Namespace
    Dim FolderSelected As Outlook.MAPIFolder
    Dim varSender As String
    Dim itm As Object
    Dim lngColIndex As Long
   
    On Error GoTo ErrHandler
    Set appExcel = Application 'CreateObject("Excel.Application")
    Set appOutlook = GetObject(, "Outlook.Application")
    appExcel.Application.Visible = True
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets(1)
    appExcel.GoTo wks.Cells(1)
    Set nms = appOutlook.GetNamespace("MAPI")
    Do
        'Stop
        Set FolderSelected = nms.PickFolder
        'Handle potential errors with Select Folder dialog box.
        If FolderSelected Is Nothing Then
            MsgBox "There are no mail messages to export", vbOKOnly, "Error"
            GoTo JumpExit
        ElseIf FolderSelected.DefaultItemType <> olMailItem Then
            MsgBox "These are not Mail Items", vbOKOnly, "Error"
            GoTo JumpExit
        ElseIf FolderSelected.Items.Count = 0 Then
            MsgBox "There are no mail messages to export", vbOKOnly, "Error"
            GoTo JumpExit
        End If
        'Copy field items in mail folder.
        intRowCounter = 1
        lngColIndex = 1
        wks.Cells(intRowCounter, lngColIndex).Resize(, 9).Value = Array("To", "From", "Subject", "Body", "Received", "Folder", "Category", "Flag Status", "Client")
        intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
        For Each itm In FolderSelected.Items
            intColumnCounter = 1
            If TypeOf itm Is MailItem Then
                Set msg = itm
                intRowCounter = intRowCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.To
                '============================================================
                varSender = ResolveDisplayNameToSMTP(msg.SenderEmailAddress, appOutlook)
                If varSender = vbNullString Then varSender = msg.SenderEmailAddress
                '============================================================
                wks.Cells(intRowCounter, 2).Resize(, 8).Value = Array(varSender, RemoveREFW(msg.Subject), Left(msg.Body, 50), msg.ReceivedTime, FolderSelected.Name, msg.Categories, msg.FlagStatus, "=ISNA(MATCH(RC[-7],NonClient,0))")
                varSender = vbNullString
            End If 'TypeOf
        Next itm
    Loop
JumpExit:
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set FolderSelected = Nothing
    Set itm = Nothing
    Exit Sub
ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
        MsgBox Err.Number & "; Description: " & Err.Description & vbCrLf & msg.ReceivedTime & vbCrLf & msg.Subject, vbOKOnly, "Error"
    End If
    Err.Clear: On Error GoTo 0: On Error GoTo -1
    GoTo JumpExit
   
End Sub
 
 
Function ResolveDisplayNameToSMTP(sFromName, objApp As Object)
   
    Dim oRecip As Recipient
    Dim oEU As ExchangeUser
    Dim oEDL As ExchangeDistributionList
   
    Set oRecip = objApp.Session.CreateRecipient(sFromName)
    oRecip.Resolve
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry, OlAddressEntryUserType.olOutlookContactAddressEntry
            Set oEU = oRecip.AddressEntry.GetExchangeUser
            If Not (oEU Is Nothing) Then
                ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
            Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
            If Not (oEDL Is Nothing) Then
                ResolveDisplayNameToSMTP = oEDL.PrimarySmtpAddress
            End If
        End Select
    End If
   
End Function
 
 
Private Function RemoveREFW(str As String) As String
 
 
    If Left$(UCase(str), 3) = "RE:" Or Left$(UCase(str), 3) = "FW:" Then
        str = Trim$(Mid$(str, 4))
    ElseIf Left(UCase(str), 4) = "FWD:" Then
        str = Trim$(Mid$(str, 5))
    End If
    RemoveREFW = Trim$(Replace$(Replace$(Replace$(str, "RE:", "", , , vbTextCompare), "FW:", "", , , vbTextCompare), "FWD:", "", , , vbTextCompare))
   
End Function
 
hi sam,
when i run the macro it is showing the following error attached
 

Attachments

  • errorexcel.jpg
    errorexcel.jpg
    23.6 KB · Views: 30
I ran the code, and I am not able to replicate that error. I am assuming it's because outlook got closed. Can anybody else test the code please? You just need to keep Outlook open, open a fresh workbook, and include the Outlook reference library, and run the code
 
Good to be back after a while, though I don't know for how long. So first thing's first.... webmax, were you able to get it to work eventually, or did you need any help.

Cheran, can you explain your requirement. What I think you want to do is to push data in to different workbooks for each different subject line... so if the subject is ABC, then put the information in to workbook UVW.xlsx, and if subject is DEF, then put the information in to workbook XYZ.xlsx... If that is what you wanted to do, you can do a 'lazy-developer's-modification' like so.

Code: 
Const strFilePath As String = "C:\Users\Public\Documents\Excel\UVW.xlsx"
Const strSubjectLineStartWith As String = "ABC"
Const strFilePath1 As String = "C:\Users\Public\Documents\Excel\XYZ.xlsx"
Const strSubjectLineStartWith1 As String = "DEF"
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
   
    Dim varArray As Variant
    Dim strSub As String
    Dim strBody As String
    Dim strArray() As String
    Dim lngLoop As Long
    Dim objItem As Object
    Dim lngMailCounter As Long
    Dim objMItem As MailItem
    strArray = Split(EntryIDCollection, ",")
    For lngMailCounter = LBound(strArray) To UBound(strArray)
        Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
        If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
            Set objMItem = objItem
            With CreateObject("Excel.Application").workbooks.Open(strFilePath)
                With .sheets(1)
                    With .cells(.rows.Count, 1).End(-4162)(2).resize(1, 7)
                        .Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
                    End With
                End With
                .Close 1
            End With
            Set objItem = Nothing
        ElseIf TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith1) And InStr(1, objItem.Body, "") Then
            Set objMItem = objItem
            With CreateObject("Excel.Application").workbooks.Open(strFilePath1)
                With .sheets(1)
                    With .cells(.rows.Count, 1).End(-4162)(2).resize(1, 7)
                        .Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
                    End With
                End With
                .Close 1
            End With
            Set objItem = Nothing
        End If
    Next lngMailCounter
    If Not IsEmpty(strArray) Then
        Erase strArray
    End If
   
End Sub

As you can see, I just added a couple of constants, and used an ElseIf condition. Again, not my favorite thing to do, but it's effective nonetheless. Let me know if you have any queries.
 
I Sam,

Requried you help
i wanted to create a VBA Code in excel where i can extract details from outlook second folder which is Inbox or sent item or deleted item details likes (From,Subject,Recived etc.) actually i have 2 mail box in outlook 1 is mine and other is of team, so i wanted to capture calendar (Meetings) of team
 

Attachments

  • Mail and calander.xls
    146.5 KB · Views: 76
Hi,
This can be done from Excel itself. Copy the code in this article link.

While Executing the code, the outlook should be running in your desktop. This macro will read the mails from your outlook and write it to Excel. It has option to mention the Mailbox and Folder name.

Thanks.
 
Sam, not sure if you are still following this thread. The code you posted is great! But have some specific questions.

Re: 1st code above for Outlook

1) Location for pasting code.
I added a module to "This Outlook Session" and pasted your code there (I thought this was the way you suggested above). This however seemed not to work and didn't fire when emails came in. So I then pasted into a VBA window in "This Outlook Session" directly and it seemed to work this way.
Question: Is this the right way this is supposed to work? Seems different from your instructions above.

2) Saving workbook problem.
The code seems to operate in the background on an excel workbook that is closed. However if I have that workbook open, it triggers a popup window for saving the workbook. Since there is already a workbook of that name (the one opened), the window default save name is "Copy of...". If you try to adjust to the original name by deleting the "Copy of" it does not allow this and says "locked for editing". But if you save "Copy of..." then that doesn't match the Path in your code.
Question: Is there a way to adjust your code so it will look if the workbook defined at the beginning of your code is already opened and in use, and if yes, then just add the new info to that workbook?

3) Look for specific folder.
Question: How can I adjust your code to look just in a specific Outlook account inbox (I have both my exchange server company inbox and also a separate Yahoo inbox)?

4) Select what is transferred.
Question: Is there a way to filter what this program selects so, for example, I can select only those from a specific user. In this case I am having my mobile SMS messages forwarded to Outlook, all of which are to: ""[Mobile:].
So I'm looking for a way to select only these messages to push into excel. An alternative is for all the incoming SMS messages, the sender appears as a phone number all with a "+" before the phone number, so I could somehow filter by this.

5) Reverse order.
Question: A Simple one. Is there a way to reverse the order that the info is dumped into excel, so the most recent are at the top?

6) Hyperlink back to Outlook.
Question: More challenging: Is there a way to set a hyperlink on the excel sheet next to the data or as part of the data so that when a user clicks on that it would open up the Outlook item where that data came from?

I realize these are quite a few questions, but they all relate to that first code you posted. Thanks so much to Sam or anybody who can help out with this!

I apologize to the forum if I'm in any way violating protocol. This is my first post.
 
Hi Sam,

Fantastic Code work like a magic. I want to know is it possible to restruct the code to paste the entire/log in the excel file if it is already present.

Like in case if I extracted the data from the inbox and again run the macro and mistakenly click the Indox option then the code should not pull the duplicate entries from outlook into Excel.

Either it should refresh the excel in such scenerio of there should be a way to avoid duplicate entries.

Please let me know the way around to dealth with this issue.

Regards,
JD
 
Hi,

I used your code to extract content from emails to xlsx, but I cannot extract each line in a different cell. Here is the code that I used!

Code: 
Const strFilePath As String = "C:\DB.xlsx"
Const strSubjectLineStartWith As String = ""
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
  
  Dim varArray As Variant
  Dim strSub As String
  Dim strBody As String
  Dim strArray() As String
  Dim lngLoop As Long
  Dim objItem As Object
  Dim lngMailCounter As Long
  Dim objMItem As MailItem
  strArray = Split(EntryIDCollection, ",")
  For lngMailCounter = LBound(strArray) To UBound(strArray)
  Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
  If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
  Set objMItem = objItem
  With CreateObject("Excel.Application").workbooks.Open(strFilePath)
  With .sheets(1)
  With .cells(.rows.Count, 1).End(-4162)(2).resize(1, 7)
  .Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
  End With
  End With
  .Close 1
  End With
  Set objItem = Nothing
  End If
  Next lngMailCounter
  If Not IsEmpty(strArray) Then
  Erase strArray
  End If
  
End Sub

Here is content of my emails:

23372919

23372920

23372921

23372923

23372924

23372939

23372940

23372946

23372952

23372957

23372962

and the code extract all those numbers into one cell. I want each number in different cell! Can you help me? Thank you!
 
Last edited by a moderator:
Hi,
I used the above code and it works perfectly, i need a slight modification, instead of checking emails from outlook folder, can it do the same for the emails saved in a desktop folder?

I have about 100 emails saved in a folder in desktop, i want to extract same info from those emails.

regards
Arvind
 
You must log in or register to reply here.
Back
Top