VBA macro to import data from emails saved in a folder

Hi,

I need a help on a macro for importing outlook data into excel.

I have saved about 100 emails in a folder.

is there a macro to get information from all those emails in to excel?

From, To, Subject, Received date, Body of the email.

Regards
Arvind

cross post:- http://www.mrexcel.com/forum/excel-questions/897590-visual-basic-applications-macro-import-data-emails-saved-folder.html#post4324208

See http://www.gmayor.com/extract_data_from_email.htm & http://www.gmayor.com/extract_email_data_addin.htm

Hi,

Thanks Graham, however the attached codes give an option to extract information from emails in outlook, but what i need is, i have saved about 200 emails in .msg format in my desktop, i need information from those emails,

Regards
Arvind

OK, the procedure is much the same, but first you have to open the files in Outlook. You can do that with a simple loop e.g.

Code:

---

Sub ProcessMSGFiles()
Const strFolder As String = "C:\Path\"        ' the location where the messages are saved
Dim strMessage As String
Dim olItem As Outlook.MailItem
    strMessage = Dir$(strFolder & "*.msg")
    While strMessage <> ""
        Set olItem = Application.CreateItemFromTemplate(strFolder & strMessage)
        olItem.Display
        'Grab the data from olitem here
        olItem.Close olDiscard
        strMessage = Dir$()
    Wend
lbl_Exit:
    Exit Sub
End Sub

---

Hi,
Thank you,

I am struggling to modify the existing code with yours.

this is the code that i have which extract information form mail folder

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(, 5).Value = Array("To", "From", "Subject", "Body", "Received")
        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(, 4).Value = Array(varSender, RemoveREFW(msg.Subject), Left(msg.Body, 2000), msg.ReceivedTime)
                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

---

can you plz help

Hi,
did you get a chance to look at this?