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，所以任何帮助都会受到赞赏。

错误信息：运行时错误＆＃39; 50290＆＃39;：应用程序定义或对象定义错误。 - ＆GT;发生在第363次迭代

在调试时重新启动并在以相同方式失败之前达到540.

然后我重新开始，结束了。

所以现在我的问题是为什么会发生这种情况？

Answer 1

在在线配置文件中（与缓存相反），Exchange将限制您可以打开的项目数量（默认为250.您需要确保通过将对象设置为Northing（VBA）或致电Marshal来明确释放这些对象.Net中的.ReleaseComObject。您还应确保不使用多极点表示法来避免无法显式释放的隐式变量。

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

对于大量项目，宏失败

1 个答案: