VBA macro to import data from emails saved in a folder

[aravindhan_3]

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
(http://www.mrexcel.com/forum/excel-questions/897590-visual-basic-applications-macro-import-data-emails-saved-folder.html#post4324208)

[gmayor]

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

[aravindhan_3]

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

[gmayor]

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.


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

[aravindhan_3]

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



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

[aravindhan_3]

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