Copying all the emails from Outlook inbox plus subfolders to excel

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