Copying all the emails from Outlook inbox plus subfolders to excel

Hi All,

My query is. Im trying to copy all the email items from outlook inbox,sub folders and public folders to excel. I have tried many codes which were posted online by other experts but for some reason im not able to get them work.

I have a VBA code shared by one of the experts which lets me choose only one folder at a time. Is there any way we can modify this code to add a functionality to it so that I can select multiple foders to export all the recieved email items to excel. Also, can we append the data exported rather than overwriting it into excel.

Any help would be greatly appreciated. Thanks in advance.

Please refer to the code below.

Option Explicit

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

Also, a speacial mention to Andy Pope whom I followed from other forums for his great help to his fellow members.

The code which he helped in optimising for better performance is below.

 '
 '
 ' Requires reference to Outlook library
 '
Public Sub ListOutlookFolders()
     
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim rngOutput As Range
    Dim lngCol As Long
    Dim olItem As Outlook.MailItem
     
    Set rngOutput = ActiveSheet.Range("A1")
     
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
     
    For Each olFolder In olNamespace.Folders
        rngOutput = olFolder.Name
        rngOutput.Offset(0, 1) = olFolder.Description
        Set rngOutput = rngOutput.Offset(1)
       For Each olItem In olFolder.Items
    If olItem.Class = olMail Then
        Set rngOutput = rngOutput.Offset(1)
        With rngOutput
            .Offset(0, 1) = olItem.SenderName ' Sender
            .Offset(0, 2) = olItem.Subject ' Subject
            .Offset(0, 3) = olItem.ReceivedTime ' Received
            .Offset(0, 4) = olItem.ReceivedByName ' Recepient
            .Offset(0, 5) = olItem.UnRead ' Unread?
            .Offset(0, 6) = olItem.ReplyRecipientNames '
            .Offset(0, 7) = olItem.SentOn
        End With
    End If
Next

         
        Set rngOutput = ListFolders(olFolder, 1, rngOutput)
    Next
     
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
     
End Sub
Function ListFolders(MyFolder As Outlook.MAPIFolder, Level As Integer, Output As Range) As Range
     '
     '
     '
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Outlook.MailItem
    Dim lngCol As Long
     
    For Each olFolder In MyFolder.Folders
        lngCol = ((Level - 1) * 8) + 1
        Output.Offset(0, lngCol) = olFolder.Name
        Set Output = Output.Offset(1)
        If olFolder.DefaultItemType = olMailItem Then
    For Each olItem In olFolder.Items
        If olItem.Class = olMail Then
            With Output
                .Offset(0, lngCol + 1) = olItem.SenderName ' Sender
                .Offset(0, lngCol + 2) = olItem.Subject ' Subject
                .Offset(0, lngCol + 3) = olItem.ReceivedTime ' Received
                .Offset(0, lngCol + 4) = olItem.ReceivedByName ' Recepient
                .Offset(0, lngCol + 5) = olItem.UnRead ' Unread?
                .Offset(0, lngCol + 6) = olItem.ReplyRecipientNames '
                .Offset(0, lngCol + 7) = olItem.SentOn
                 
            End With
            Set Output = Output.Offset(1)
        End If
    Next
End If

        If olFolder.Folders.Count > 0 Then
            Set Output = ListFolders(olFolder, Level + 1, Output)
        End If
    Next
    Set ListFolders = Output.Offset(1)
     
End Function

Apparently this code was working perfectly fine for the person who originally posted the question. But for me Im getting an error at this line "Set rngOutput = ActiveSheet.Range("A1")" as Öbject Variable or With block variable not set". Please help me in this reagrds.


Thanks in advance.

P.S. Im a newbie @ VBA coding.

try this modification on the code and let me know if it works

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.Folder
  
  Dim itm As Object
  
  strSheet = "OutlookItems.xls"
  strPath = "C:\Examples\"
  strSheet = strPath & strSheet
  Debug.Print strSheet
  
  'Select export folder
  Set nms = Application.GetNamespace("MAPI")
  For Each fld In nms.Folders(1).Folders
  
      '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"
        GoTo 1:
      End If
      
      'Open and activate Excel workbook.
    If appExcel Is Nothing Then
        Set appExcel = CreateObject("Excel.Application")
        appExcel.Workbooks.Open (strSheet)
        Set wkb = appExcel.ActiveWorkbook
        Set wks = wkb.Sheets(1)
        wks.Activate
        appExcel.Application.Visible = True
    End If
       
      'Copy field items in mail folder.
      For Each itm In fld.Items
        On Error Resume Next
        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
        On Error GoTo 0
      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
1:
Next fld
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

Hi Mohd,

It works magical, thanks heaps for your help. A quick question will it pick emails from Sent, Draft, Deleted & Junk as well??

Is there anyway I can specify from which folder only it should pick up??

Thanks again Mohd :D

If you want to exclude items from the export you specify them like this:

.
.
.
For Each fld In nms.Folders(1).Folders
     IF fld.Name = "Deleted Items" OR fld.Name =  "Sent Items" OR fld.Name =  "Whatever" Then
            goto 1:
     end if
.
.
.
.

Well this is interesting... It is not looking for subfolders under the main Inbox folder. So its picking up all the emails from Inbox and sent emails, deleted emails etc.. but not subfolders under Inbox.
And yea I tried excluding the Inbox folder and deleted all the emails from sent and deleted folder except for subfolders. And Im getting an error as "No email items found"

What do u reckon the problem is??

try this

Option Explicit


Sub ExportToExcel()
On Error GoTo 0
Dim nms As Outlook.NameSpace
Dim fld As Outlook.Folder
Dim Mainfld As Outlook.Folder
'Select export folder
Set nms = Application.GetNamespace("MAPI")
For Each Mainfld In nms.Folders(1).Folders
    If Mainfld Is Nothing Then GoTo 1:
    GetEmails Mainfld
    If Mainfld.Folders.Count > 0 Then
        For Each fld In Mainfld.Folders
            GetEmails fld
        Next fld
    End If
1:
Next Mainfld
End Sub
Sub GetEmails(fld As Outlook.Folder)
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 itm As Object

strSheet = "OutlookItems.xls"
strPath = "E:\Examples\"
'strSheet = strPath & strSheet
Debug.Print strPath & strSheet
Debug.Print fld.FolderPath
'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 in " & fld.FolderPath, vbOKOnly, _
    "Error"
    Exit Sub
ElseIf fld.Items.Count = 0 Then

    MsgBox "There are no mail messages to export in " & fld.FolderPath, vbOKOnly, _
    "Error"
    Exit Sub
End If

'Open and activate Excel workbook.
On Error Resume Next
Set appExcel = GetObject(, "excel.application")
On Error GoTo 0
If appExcel Is Nothing Then
    Set appExcel = CreateObject("Excel.Application")
End If
On Error Resume Next
Set wkb = appExcel.Workbooks(strSheet)
If wkb Is Nothing Then
    appExcel.Workbooks.Open (strPath & strSheet)
End If
On Error GoTo 0
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
    On Error Resume Next
    intColumnCounter = 1
    Set msg = itm
    intRowCounter = wks.Range("E" & wks.Rows.Count).End(xlUp).Row + 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
    On Error GoTo 0
Next itm
End Sub

Awesome! ... works perfectly It is looping through every folder now. How do I exclude specific folders if I want to?? like you've mention in the previous post??
And also, how can give headers (From, To and Sent)?? Im sorry too many questions.

Thanks a trillion