我有一个运行宏,在大量项目上运行时看似随机点失败。宏通过接收错误日志的收件箱文件夹,用来循环,保存错误日志的文本文件,复制从附件文本的指定行(错误操作名称和等),将这些字符串中的Excel文件来跟踪它们,然后将电子邮件项目移动到另一个收件箱文件夹中。当它通过少于100封电子邮件时,它的效果很好,但最重要的是它很奇怪。在第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之前以相同的方式失败。
然后我重新启动,它完成了。
所以现在我的问题是为什么会发生这种情况?
很难说,如果这是不好的做法时,我们没有但除非你真的有很大的实例,或者如果你试图编译关于所有项目的整体数据,那么_probably_并不是一个坏习惯。 – litelite
是共享文件夹中的excel文件吗? – litelite
否其本地副本 – mmoschet