Export Email from Outlook 2010 to excel

[sachin483]

I have Outlook 2010 and office 2010 i want to extract email from outlook in below format with body ,and attachment download to a particular folder, with parameter as date ie:- example for 1 month i want to download or for 6 months

To - From - Subject - Body - Received - Folder

[HansV]

The body of an email can be quite long and contain pictures; it is not really suitable to put it in a cell in an Excel worksheet.

[sachin483]

Can we ignore all the pictures and extract the text only because i have to do some work on body of the mail.

[HansV]

What do you want in the Folder column?

[HansV]

And which Outlook folder do you want to process? The Inbox?

[sachin483]

Mostly it will be inbox but can we keep selection for that ,sometimes can be sent

[HansV]

This might take a while. My Outlook VBA is rusty.

[HansV]

Here is an attempt. Change strFolder to the folder where you want the attachments to be saved.
The code should be run from Outlook, and you should activate the Outlook folder to be exported before running the macro ExportItems. The other code is needed for the macro.

Code: Select all

Sub ExportItems()
    Dim lngVersion As Long
    Dim f As Boolean
    Dim xlApp As Object
    Dim xlWbk As Object
    Dim xlWsh As Object
    Dim lngRow As Long
    Dim olkMsg As Object
    Dim lngMessages As Long
    Dim i As Long
    Dim olkFolder As Folder
    Dim dStart As Date
    Dim dEnd As Date
    Dim RestrictedItems As Items
    Const strFolder = "C:\Temp\" ' Modify as needed, keep \ at end
    If TypeName(ActiveWindow) <> "Explorer" Then
        MsgBox "Please activate the Outlook application window, then try again.", vbInformation
        Exit Sub
    End If
    On Error Resume Next
    dStart = InputBox(Prompt:="Enter the start date", Default:=DateAdd("m", -2, Date))
    dEnd = InputBox(Prompt:="Enter the end date", Default:=Date)
    If Err Then Exit Sub
    On Error GoTo ErrHandler
    Set olkFolder = ActiveExplorer.CurrentFolder
    Set RestrictedItems = olkFolder.Items.Restrict(Filter:="[ReceivedTime]>='" & Format(dStart, "yyyy/mm/dd") & _
        "' AND [ReceivedTime]<='" & Format(dEnd, "yyyy/mm/dd") & "'")
    lngVersion = GetOutlookVersion
    On Error Resume Next
    Set xlApp = GetObject(Class:="Excel.Application")
    If xlApp Is Nothing Then
        Set xlApp = CreateObject(Class:="Excel.Application")
        f = True
    End If
    On Error GoTo ErrHandler
    Set xlWbk = xlApp.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet
    Set xlWsh = xlWbk.Worksheets(1)
    lngRow = 1
    With xlWsh
        .Cells(1, 1).Value = "To"
        .Cells(1, 2).Value = "From"
        .Cells(1, 3).Value = "Subject"
        .Cells(1, 4).Value = "Body"
        .Cells(1, 5).Value = "Received"
        .Cells(1, 6).Value = "Attachments"
        'Write messages to spreadsheet
        For Each olkMsg In RestrictedItems
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row
                lngRow = lngRow + 1
                lngMessages = lngMessages + 1
                .Cells(lngRow, 1).Value = olkMsg.ReceivedByName
                .Cells(lngRow, 2).Value = GetSMTPAddress(olkMsg, lngVersion)
                .Cells(lngRow, 3).Value = olkMsg.Subject
                .Cells(lngRow, 4).Value = Replace(Replace(olkMsg.Body, vbCr, vbLf), Chr(11), vbLf)
                .Cells(lngRow, 5).Value = olkMsg.ReceivedTime
                For i = 1 To olkMsg.Attachments.Count
                    .Cells(lngRow, 5 + i) = olkMsg.Attachments(i).FileName
                    olkMsg.Attachments(i).SaveAsFile strFolder & lngMessages & "_" & i & "_" & _
                        olkMsg.Attachments(i).FileName
                Next i
            End If
        Next olkMsg
        .Range("A1:C1,E1").entirecolumn.AutoFit
    End With
ExitHandler:
    On Error Resume Next
    If f Then
        xlApp.Visible = True
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Function GetSMTPAddress(Item As Object, lngOutlookVersion As Long) As String
    Dim olkSnd As Object
    Dim olkEnt As Object
    On Error Resume Next
    Select Case lngOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = 0 Then ' olExchangeUserAddressEntry
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
End Function

Function GetOutlookVersion() As Long
    Dim arrVer As Variant
    arrVer = Split(Application.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Object) As String
    Dim olkPA As Object
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
End Function

[sachin483]

Thanks working fine