Макрос не удается для больших наборов предметов

Question

У меня есть работающий макрос, который не работает в кажущихся случайными точками при работе на большом количестве предметов. Макрос используется для прокрутки папки «Входящие», которая принимает журналы ошибок, сохраняет текстовые файлы журнала ошибок, копирует указанные строки текста из вложений (имена операций с ошибкой и т. Д.), Помещает эти строки в файл excel для их отслеживания и затем переместите элементы электронной почты в другую папку входящих сообщений после ее обработки. Он отлично работает, когда он проходит менее ста электронных писем, но, прежде всего, становится странным. При тестировании его отказа на 122-й итерации 648, 350 и т. Д. Общая структура приведена ниже.

Sub ErrorLogAuto() 

Dim FileName As String 
Dim Path As String 
Dim TimeInfo As String 
Dim SubjectInfo As String 
Dim IdNumber As String 
Dim Dataline As String 

Dim oItem As Object 
Dim Item As Outlook.Items 
Dim myAttachment(1000) As Outlook.Attachments 
Dim myInspector As Outlook.Inspector 

Dim appExcel As Object 

Dim FileNum As Integer 
Dim found As Integer 
Dim found1 As Integer 
Dim found2 As Integer 
Dim i As Integer 
Dim j As Integer 
Dim op As Integer 
Dim us As Integer 
Dim cdata As Integer 

i = 0 
k = 1 

'Returns proper SOURCE folder 
Set myNameSpace = Application.GetNamespace("MAPI") 
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox) 
Set myNewFolder = myFolder.Folders("Test") '--> text between "" is the folder name, only change it here 

'set path for attachments to be saved in 
Path = "C:\test\" 

'Set item = to all emails in test folder 
Set Item = myNewFolder.Items 

'If no emails... 
If Item.Count = 0 Then 
    MsgBox "There are no error messages to sift through." 
    Exit Sub 
End If 

'Open an instance of excel to certain workbook 
Set appExcel = CreateObject("Excel.Application") 
appExcel.Visible = True 
'appExcel.Workbooks.Open (Path & "test.xlsx") 
appExcel.Workbooks.Open (Path & "SAMPLE FILE NAME.xlsx") 

'Find first empty cell to write to --> based off of column D 
While appExcel.Range("D" & k) <> "" 
    k = k + 1 
Wend 

'For every email in folder...here starts the big loop 
For Each oItem In Item 

    'Save attachment and set filename 
    Set myAttachment(i) = oItem.Attachments 
     myAttachment(i).Item(1).SaveAsFile Path & myAttachment(i).Item(1).DisplayName & ".txt" 
     FileName = Path & myAttachment(i).Item(1).DisplayName & ".txt" 

    'Subject and time info 
    SubjectInfo = oItem.Subject 
    TimeInfo = oItem.ReceivedTime 

    'Returns ID number from subject string after '@' 
    j = InStr(SubjectInfo, "@") 
    IdNumber = Mid(SubjectInfo, j + 1) 

    'Write IdNumber to cell and timestamp 
    appExcel.Range("A" & k) = TimeInfo 
    appExcel.Range("D" & k) = IdNumber 


    'Open the notepad file, read line by line until EOF, take user message, and take operation name 
    FileNum = FreeFile() 
    Open FileName For Input As #FileNum 

    While Not EOF(FileNum) 

     Line Input #FileNum, Dataline 

     'If string found these will <> 0 
     found = InStr(Dataline, "<OperationName>") 
     found1 = InStr(Dataline, "<UserMessage>") 
     found2 = InStr(Dataline, "<UserMessage><![CDATA[") 

     'Returns position right after where string is found 
     op = InStr(Dataline, "<OperationName>") + 15 
     us = InStr(Dataline, "<UserMessage>") + 13 
     cdata = InStr(Dataline, "<UserMessage><![CDATA[") + 22 

     'Found operation name line 
     If found <> 0 Then 
      'appExcel.Range("B1") = Dataline --> whole line 
      'appExcel.Range("C" & k) = Mid(Mid(Dataline, 20), 1, Len(Mid(Dataline, 20)) - 16) --> doesnt account for whitespace 
      appExcel.Range("N" & k) = Mid(Mid(Dataline, op), 1, Len(Mid(Dataline, op)) - 16) '--> accounts for whitespace and cuts out <OperationName> and <\OperationName> 
     'Found user message line and it includes cdata stuff 
     ElseIf found1 <> 0 And found2 <> 0 Then 
      'appExcel.Range("C1") = Dataline --> whole line 
      'appExcel.Range("D" & k) = Mid(Mid(Dataline, 20), 1, Len(Mid(Dataline, 20)) - 14) --> doesnt account for whitespace 
      'appExcel.Range("O" & k) = Mid(Mid(Dataline, us), 1, Len(Mid(Dataline, us)) - 14) --> accounts for whitespace and cuts out <UserMessage> and <\UserMessage> 
      appExcel.Range("O" & k) = Mid(Mid(Dataline, cdata), 1, Len(Mid(Dataline, cdata)) - 17) '--> accounts for whitespace and cuts out <UserMessage><![CDATA[ and ]]><\UserMessage> 
     'Found user message line WITHOUT cdata stuff 
     ElseIf found1 <> 0 Then 
      appExcel.Range("O" & k) = Mid(Mid(Dataline, us), 1, Len(Mid(Dataline, us)) - 14) '--> accounts for whitespace and cuts out <UserMessage> and <\UserMessage> 
     End If 

    Wend 

    Close #FileNum 

    i = i + 1 
    k = k + 1 

Next 

Call FolderMove 


End Sub 

Private Sub FolderMove() 

    Dim a As MailItem 
    Dim m As Integer 
    Dim Source As MAPIFolder 
    Dim Destination As MAPIFolder 

    Set Source = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
    Set Source = Source.Folders("Test") '--> text between "" is the folder name, only change it here 

    Set Destination = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
    Set Destination = Destination.Folders("Testing Done") '--> text between "" is the folder name, only change it here 

    For m = Source.Items.Count To 1 Step -1 
     Set a = Source.Items(m) 
     a.move Destination 
    Next 

End Sub 

Код разбивается при чтении файла в цикле не EOF. Являются ли эти ошибки причиной плохой практики программирования? Я никогда раньше не работал с большими наборами и не был новым для VBA, поэтому любая помощь была бы оценена.

Сведения об ошибке: Ошибка времени выполнения '50290': ошибка, определяемая приложением или объектом. -> произошло на 363-й итерации

Перезагружено при отладке и добралось до 540, прежде чем провалиться точно так же.

Затем я перезапустил и все закончилось нормально.

Итак, теперь мой вопрос: почему это происходит?

Answer 1

В онлайн-профиле (в отличие от кэширования) Exchange ограничивает количество выходов, которые вы можете открыть (по умолчанию 250. Вам нужно убедиться, что вы явно освобождаете объекты, устанавливая их в Northing (VBA) или вызывая Marshal.ReleaseComObject в .Net. вы также должны убедиться, что вы не использовать многополюсный точечную нотацию, чтобы избежать неявной переменной, что вы не можете явно освободить.

for i = 1 to Item.Count 
    set oItem = Item.Items(i) 
    set oAttachments = oItem.Attachments 
    if oAttachments.Count > 0 Then 
    set oAttachment = oAttachments.Item(1) ' do you really want a loop through all attachments? 
    FileName = Path & oAttachment.FileName 
    oAttachment.SaveAsFile FileName 
    set oAttachment = Nothing 
    End If 
    ... 
    set oAttachments = Nothing 
    set oItem = Nothing 
Next i