vbaoutlookruntime-erroroutlook-2010

Runtime error looping through Outlook items

I am using VBA in Outlook to extract mail information from items in the mainfolder and subfolder. The mainfolder failed to set(capture) the subfolder properties into it and it causes the runtime error.

The runtime error differs whenever I run. For example, sometime I received -970718969 (c6240107) and another time I received -2044460793 (86240107).

When I clicked debug, it points to this line of code:

For Each itm In subFld.Items

Here is the screenshot: https://i.sstatic.net/y3Jcw.png

Here is the full code:

Public monthValue As Integer
Public yearValue As String

'Ensure Microsoft Excel 11.0 Object Library is ticked in tools.
Sub ExportToExcel1()

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 msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim mainFld As Outlook.MAPIFolder
Dim subFld As Outlook.MAPIFolder
Dim itm As Object
Dim offsetRow As Long
Dim emailCount As Long

'Set the path of the excel file.
strSheet = "For fun.xlsx"
strPath = "C:\Users\xxxxxx\Desktop\xxxxx\"
strSheet = strPath & strSheet

Debug.Print strSheet 

Set nms = Application.GetNamespace("MAPI")
Set mainFld = nms.PickFolder 'Open the box to select the file.

'Handle potential errors with Select Folder dialog box.
If mainFld Is Nothing Then
    MsgBox "Thank you for using this service.", vbOKOnly, "Error"
    Set nms = Nothing
    Set mainFld = Nothing
    Exit Sub
ElseIf mainFld.DefaultItemType <> olMailItem Then
    MsgBox "Please select the correct folder.", vbOKOnly, "Error"
    Set nms = Nothing
    Set mainFld = Nothing
    Exit Sub
ElseIf mainFld.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Set nms = Nothing
    Set mainFld = Nothing
    Exit Sub
End If

mainForm.Show
'If user clicks cancel, it will exit sub.
If yearValue = "" Then
    Set nms = Nothing
    Set mainFld = Nothing
    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 'Show my workbook.

'Check if there are any subfolders.
If mainFld.Folders.Count = 0 Then '1
    'No subfolder.
    For Each itm In mainFld.Items
        If itm.Class <> olMail Then '2
            'do nothing
        Else
            Set msg = itm
            'Validate the month and year for the email.
            If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '3
                With wks
                    offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                End With
                intRowCounter = 1 + offsetRow
                Set rng = wks.Cells(intRowCounter, 1)
                    rng.Value = msg.ReceivedTime
                Set rng = wks.Cells(intRowCounter, 2)
                    rng.Value = msg.SentOn
                Set rng = wks.Cells(intRowCounter, 3)
                    rng.Value = msg.Subject
                emailCount = 1 + emailCount 'Track the number of email.
            Else
                'Do nothing
            End If '3
        End If '2
    Next itm
Else
    'With subfolder
    For Each itm In mainFld.Items
        If itm.Class <> olMail Then '4
            'do nothing
        Else
            Set msg = itm
            If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '5
                With wks
                    offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                End With
                intRowCounter = 1 + offsetRow
                Set rng = wks.Cells(intRowCounter, 1)
                    rng.Value = msg.ReceivedTime
                Set rng = wks.Cells(intRowCounter, 2)
                    rng.Value = msg.SentOn
                Set rng = wks.Cells(intRowCounter, 3)
                    rng.Value = msg.Subject
                emailCount = 1 + emailCount
            Else
                'Do nothing
            End If '5
        End If '4
    Next itm
    For Each subFld In mainFld.Folders
        For Each itm In subFld.Items
            If itm.Class <> olMail Then '6
                'do nothing
            Else
                Set msg = itm
                If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '7
                    With wks
                        offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                    End With
                    intRowCounter = 1 + offsetRow
                    Set rng = wks.Cells(intRowCounter, 1)
                        rng.Value = msg.ReceivedTime
                    Set rng = wks.Cells(intRowCounter, 2)
                        rng.Value = msg.SentOn
                    Set rng = wks.Cells(intRowCounter, 3)
                        rng.Value = msg.Subject
                    emailCount = 1 + emailCount
                Else
                    'Do nothing
                End If '7
            End If '6
        Next itm
    Next subFld
End If '1


Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing

'Inform the user that there are no email.
If emailCount = 0 Then
    MsgBox "No emails associated with this date: " & MonthName(monthValue, True) & " " & yearValue, vbOKOnly, "No Emails"
End If

Exit Sub

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing

End Sub
Solution

  • Do you get that error immediately or only after processing a large number of items? Most likely you are opening too many items and run out of RPC channels. Is this a cached or an online Exchange profile?

    Instead of looping through all items, use the Table object (MAPITable.GetTable) - if nothing else, it will be a lot faster.

    EDIT: If you are using Exchange, every store object (message, folder, store) opens an RPC channel. Exchange Server limits the number of RPC channels to 255 per client (can be changed on the server). Do not use "for each" loop (it keeps all items referenced until the loop ends) and avoid multiple dot notation (because you will have implicit variables that you cannot explicitly dereference). You will also need to release all Outlook objects as soon as you are done with them.

    set fldItems = mainFld.Items
For i = 1 to fldItems.Count do
  set itm = fldItems.Item(i)
  'do stuff
  set itm = Nothing
next

    As for the Table object (introduced in Outlook 2007), see http://msdn.microsoft.com/en-us/library/office/ff860769.aspx. If you need to use this in an earlier version of Outlook, you can use the MAPITable object in Redemption (I am its author); it also has a MAPITable.ExecSQL method that takes a standard SQL query and returns the ADODB.Recordset object.