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

Outlook Email Export to excel, getting errror

ThrottleWorks

ThrottleWorks

Excel Ninja
Hi,

I am using below mentioned code (copied from http://officetricks.com/outlook-email-download-to-excel/) to export e-mails to excel sheet.

This code runs fine at my PC, however it gives me error when I tried running it on another PC.

Run Time Error The attempted operation failed. An object could not be found.
I am getting bug at 'For Each Folder In Outlook.Session.Folders(MailBoxName).Folders' this line.

I checked 'MailBoxName' name in immediate window, it is populated correctly.
I am not able to understand, what is causing bug. Can anyone help me in this please.


Code: 
'http://officetricks.com/outlook-email-download-to-excel/
Option Explicit
'This Code is Downloaded from OfficeTricks.com
'Visit this site for more such Free Code
Sub Download_Outlook_Mail_To_Excel()
    Application.ScreenUpdating = False
    'Add Tools->References->"Microsoft Outlook nn.n Object Library"
    'nn.n varies as per our Outlook Installation
    Dim Folder As Outlook.MAPIFolder
    Dim sFolders As Outlook.MAPIFolder
    Dim iRow As Integer, oRow As Integer
    Dim MailBoxName As String, Pst_Folder_Name  As String
  
    'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
    MailBoxName = "name.name@name.com"
    'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
    Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items"
    'To directly a Folder at a high level
    'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)
  
    'To access a main folder or a subfolder (level-1)
    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
        If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
        For Each sFolders In Folder.Folders
            If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
                Set Folder = sFolders
                GoTo Label_Folder_Found
            End If
        Next sFolders
    Next Folder
Label_Folder_Found:
    If Folder.Name = "" Then
        MsgBox "Invalid Data in Input"
        GoTo End_Lbl1:
    End If
    'Read Through each Mail and export the details to Excel for Email Archival
    ThisWorkbook.Sheets(1).Activate
    Folder.Items.Sort "Received"
  
    'Insert Column Headers
    ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
    ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
    ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
    ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
    ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
    'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"
  
    'Export eMail Data from PST Folder
    oRow = 1
    For iRow = 1 To Folder.Items.Count
        'If condition to import mails received in last 60 days
        'To import all emails, comment or remove this IF condition
        If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) = 0 Then
          oRow = oRow + 1
          ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
          ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
          ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
          ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
          ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
          ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
          ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
        End If
    Next iRow
    MsgBox "Outlook Mails Extracted to Excel"
    Set Folder = Nothing
    Set sFolders = Nothing
  
End_Lbl1:
Application.ScreenUpdating = True
End Sub
 
Only reason I can think of is MailBoxName as it can be email address or simple text. I see that you checked MailBoxName in Immediate Window, but can you double check?

Run below code and copy paste what comes up (single line) into your code and see what happens.

Code: 
Sub ListMailBoxName()
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim nSpace As Outlook.Namespace
Dim Inbox As MAPIFolder
Dim I As Long
Dim X As Long

Set olApp = CreateObject("Outlook.Application")
Set nSpace = olApp.GetNamespace("MAPI")

X = nSpace.Session.Folders.Count

For I = 1 To X
        Debug.Print nSpace.Session.Folders(I).Name
Next
End Sub
 
Hi,
I am using below mentioned code to export e-mail to excel.
Copied from http://www.techrepublic.com/blog/microsoft-office/quickly-export-outlook-e-mail-items-to-excel/

I am getting bug as 'Run Time Error 438 Object does not support this property or method' on 'Set nms = Application.GetNamespace("MAPI")' line.

I have added reference for MS Outlook object. Can anyone please help me in this.

Code: 
'http://www.techrepublic.com/blog/microsoft-office/quickly-export-outlook-e-mail-items-to-excel/
Sub ExportToExcel()
  
    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
  
    strPath = ThisWorkbook.Path
    strSheet = strPath & 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 wkb = ThisWorkbook
    Set wks = ThisWorkbook.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
    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

PS - Would like to share below mentioned code, it works smoothly.
http://www.codeproject.com/Questions/564777/ExportplusOutlookplusEmailplusbodyplustoplusExcelp

Code: 
'http://www.codeproject.com/Questions/564777/ExportplusOutlookplusEmailplusbodyplustoplusExcelp
Sub Macro_05()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
    For i = 1 To myfolder.Items.Count
        Set myitem = myfolder.Items(i)
        msgtext = myitem.Body
       
        If VBA.DateValue(VBA.Now) - VBA.DateValue(myfolder.Items(i).ReceivedTime) = 0 Then
            Range("a" & i + 1).Value = myitem.To
            Range("b" & i + 1).Value = myitem.ReceivedTime
            Range("c" & i + 1).Value = msgtext
        End If
    Next
    MsgBox "Done !"
End Sub
 
Last edited:
Change
Code: 
Set nms = Application.GetNamespace("MAPI")

To
Code: 
Set nms = Outlook.Application.GetNamespace("MAPI")

Edit: One more thing. You need to add following or it will give error. As the code is missing Object variable for appExcel.

Code: 
Set appExcel = Excel.Application
 
Last edited:
You must log in or register to reply here.
Back
Top