• 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.

Extract information from emails saved in a folder

Aravindhan

New Member
Hi,

I got this code from a link which works perfectly when i select a folder in outlook.
retrieving data from mails(outlook) using excel/vba | Chandoo.org Excel Forums - Become Awesome in Excel
can someone help me to modify this to get same info from emails saved in a local folder

I have 200 emails saved in desktop folder, I wanted get to all these information.

can we change this to get it from a local drive where emails are saved?
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
Regards
Arvind
 
Back
Top