我有一個運行宏,在大量項目上運行時看似隨機點失敗。宏通過接收錯誤日誌的收件箱文件夾,用來循環,保存錯誤日誌的文本文件,複製從附件文本的指定行(錯誤操作名稱和等),將這些字符串中的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