Run Time Error "13" on For Each loop

B

BrianA

Joined
Mar 20, 2012
Messages
1
Reaction score
0
Hi All,

Trying to get all emails addresses from Outlook to an Excel sheet and I found this code:

Code: 
 '
 ' 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

    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String

    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
            Set rngOutput = rngOutput.Offset(1)
            With rngOutput
                .Offset(0, 1) = olItem.SenderEmailAddress ' Sender
            End With
        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
        Output.Offset(0, lngCol) = olFolder.Name
        Set Output = Output.Offset(1)
        
        If (olFolder.DefaultItemType = olMailItem) And (Not olFolder.Name = "Slettet post") Then
            For Each olItem In olFolder.Items
                If olItem.Class = olMail Then
                    With Output
                        .Offset(0, 1) = olItem.SenderEmailAddress ' Sender
                    End With
                    Set Output = Output.Offset(1)
                End If
            Next olItem  ' <-- ERROR - states it's empty!?
        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

It's working perfect for 10-100 emails but the out of the blue a Run time Error 13 occurs in Function Listfolder (Next olItem) and debugger states it's empty :cry:. If I simply press debug and "Step Into" the code continues without any problems!?

Any help will be greatly appreciated.
 
Back
Top