Copy data from emails in Outlook Inbox and personal subfolders to Excel through VBA

I need to copy the name, subject and received date fields from emails received in my Outlook 2007/2010 inbox, subfolders and public shared folders to Excel 2007/2010.

Also when I export to Excel it should append data every time I run the macro.

This code, which I got online, allows me to pick a folder but not multiple selection. Is there a way to select multiple folders.

Source link to the code: https://web.archive.org/web/1/http://i.techrepublic%2ecom%2ecom/downlo...k_to_excel.zip

Sub ExportToExcel()

On Error GoTo ErrHandler

Dim appExcel As Excel.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 fld As Outlook.MAPIFolder
Dim itm As Object

strSheet = "OutlookItems.xls"
strPath = "C:\Examples\"
strSheet = strPath & strSheet
Debug.Print strSheet

'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no 开发者_开发百科mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.
For Each itm In fld.Items
    intColumnCounter = 1
    Set msg = itm
    intRowCounter = intRowCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.To
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SenderEmailAddress
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.Subject
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SentOn
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.ReceivedTime
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing

Exit Sub

ErrHandler:
If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, _
      "Error"
Else
    MsgBox Err.Number & "; Description: ", vbOKOnly, _
      "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing

End Sub

---

Let's break your task down a bit .... as far as I see you would need to write some code, maybe also a user form to capture the entry point of your MAPI folder structure and possibly a date parameter (items after D ...) in Outlook VBA. Then there are three major parts of the problem

1. walk through your tree of MAPI Folders - from the chosen starting point
2. identify relevant objects (mail items ... there may be other items as well in the folders)
3. capture some item data of relevant objects and write them out to Excel

ad 1: this will most probably be a recursive task to get down to the bottom of the folder structure from a certain starting point (root or any folder the user might select). Therefore I personally would be careful with public shared folders as they could hide a HUGE amount of folders/items and open all sorts of problems (excessive runtime, access restrictions etc.). Also you probably don't want to capture mail items in a "Deleted Items" folder and its sub's. Also you may want to pass a DATE parameter to such a recursive procedure - entered by the user - to capture items created/sent past a certain date.

here's a code block you can use to populate a treeview object in a user form that asks for the root MAPI Folder of the recursion and reacts on an EXPORT button (see below)

Private Sub UserForm_Initialize()
Dim N As NameSpace, F As MAPIFolder

    Set N = Application.GetNamespace("MAPI")

    ' load all main folders (and their subfolders) into TreeView_Source
    For Each F In N.Folders
        ' in my own app I don't do the Public folder, this would be too massive
        If F.Name <> "Public Folders" Then
            LoadFolder TreeView_Source, F
        End If
    Next F

    Set F = Nothing
    Set N = Nothing

End Sub

Private Sub LoadFolder(TreeViewObj As MSComctlLib.TreeView, F As MAPIFolder, Optional Base As String = "")
Dim G As MAPIFolder

    With TreeViewObj
        If Base = "" Then
            ' add as a root folder
            .Nodes.Add , tvwChild, F.EntryID, F.Name
        Else
            ' add as a child folder connected to Base
            .Nodes.Add Base, tvwChild, F.EntryID, F.Name
        End If
    End With

    ' recursive call to process subfolders of current folder
    For Each G In F.Folders
        LoadFolder TreeViewObj, G, F.EntryID
    Next G

    Set G = Nothing

End Sub

ad 2: this is easy ...

If TypeName(MyItem) = "MailItem" Then

ad 3: you need to choose whether you capture your item data in a memory structure (array, whatever) and play it out to Excel at the end of the process or if you want to continuously want to update an Excel sheet you opened at the beginning (with all the problems of a globally dim'ed object, line counter etc. I leave this open for the time being.

Here's something I extracted from a similar quest I have done myself. I rearranged it as if this would react on an "Export" button of a small user dialog:

Note: BeforeDate is really an AfterDate in this case

Private Sub CommandButton_Export_Click()
Dim N As NameSpace, D As Date, S As MAPIFolder

    D = CDate("01-Jän-2011") ' or from a field of your user form
                             ' mind the Umlaut .... 
                             ' yeep I'm from Austria and we speak German ;-)

    ' initialize objects
    Set N = Application.GetNamespace("MAPI")
    Set S = N.GetFolderFromID(TreeView_Source.SelectedItem.Key) ' this refers to a control named TreeView_Source in the current User Dialog form

    ProcessFolder S, D

End Sub

Private Sub ProcessFolder(Source As MAPIFolder, BeforeDate As Date)
' process MailItems of folder Source
' recurse for all subfolders of Source
Dim G As MAPIFolder, Idx As Long, Icnt As Long, ObjDate As Date

    ' process mail items of current folder
    If Source.Items.Count <> 0 Then
        For Idx = 1 To Source.Items.Count
            ' now this is what I mentioned in "ad 2:"
            If TypeName(Source.Items(Idx)) = "MailItem" Then
                If BeforeDate = 0 Or Source.Items(Idx).ReceivedTime >= BeforeDate Then
                    ProcessItem Source.Items(Idx)
                End If
            End If
        Next Idx
    End If

    ' go down into sub folders
    If Source.Folders.Count <> 0 Then
        For Idx = 1 To Source.Folders.Count
            ' here a folder named "Deleted Items" could be trapped
            ProcessFolder Source.Folders(Idx), BeforeDate
        Next Idx
    End If
End Sub

Sub ProcessItem(SrcItem As MailItem)
' here the capturing and eventually the writeout to Excel would occur
' for now I just have key fields printed in the debug screen

    With SrcItem
        Debug.Print .ReceivedTime, .ReceivedByName, .Subject, .Parent.FolderPath
    End With
End Sub

Hope that helps top get you going