none
Close Selected Mailbox Items After Being Processed RRS feed

  • Question

  • Hi,

    I have written the Macro below, but when I try to run it on around 4000 emails I get the following error message:

    Run-time error '-382467323 (e9340305)': Your server administrator has limited the number of items you can open simultaneously. Try closing messages you have opened or removing attachments and images from unsent messages you are composing.

    Is there any way I can close each mailbox item after it has been processed in the code i'm running is below.

    Option Explicit 
     
    Sub CopyToExcel() 
        Dim xlApp As Object 
        Dim xlWB As Object 
        Dim xlSheet As Object 
        Dim olItem As Outlook.MailItem 
        Dim vText As Variant 
        Dim sText As String 
        Dim vItem As Variant 
        Dim i As Long 
        Dim rCount As Long 
        Dim bXStarted As Boolean 
        Const strPath As String = "C:\test.xlsx" 'the path of the workbook
         
        If Application.ActiveExplorer.Selection.Count = 0 Then 
            MsgBox "No Items selected!", vbCritical, "Error" 
            Exit Sub 
        End If 
        On Error Resume Next 
        Set xlApp = GetObject(, "Excel.Application") 
        If Err <> 0 Then 
            Application.StatusBar = "Please wait while Excel source is opened ... " 
            Set xlApp = CreateObject("Excel.Application") 
            bXStarted = True 
        End If 
        On Error Goto 0 
         'Open the workbook to input the data
        Set xlWB = xlApp.Workbooks.Open(strPath) 
        Set xlSheet = xlWB.Sheets("Sheet1") 
         
         'Process each selected record
        For Each olItem In Application.ActiveExplorer.Selection 
            sText = olItem.Body 
            vText = Split(sText, Chr(13)) 
             'Find the next empty line of the worksheet
            rCount = xlSheet.UsedRange.Rows.Count 
            rCount = rCount + 1 
             
             'Check each line of text in the message body
            For i = UBound(vText) To 0 Step -1 
                If InStr(1, vText(i), "mailfieldFromAddress:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("A" & rCount) = Trim(vItem(1)) 
                End If 
                 
                If InStr(1, vText(i), "name:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("B" & rCount) = Trim(vItem(1)) 
                End If 
                 
                If InStr(1, vText(i), "university:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("C" & rCount) = Trim(vItem(1)) 
                End If 
                 
                If InStr(1, vText(i), "course:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("D" & rCount) = Trim(vItem(1)) 
                End If 
                 
            Next i 
            xlWB.Save 
        Next olItem 
        xlWB.Close SaveChanges:=True 
        If bXStarted Then 
            xlApp.Quit 
        End If 
        Set xlApp = Nothing 
        Set xlWB = Nothing 
        Set xlSheet = Nothing 
        Set olItem = Nothing 
    End Sub

    Cheers,
    Tim

    Tuesday, December 10, 2013 9:57 AM

All replies