我遇到了错误
数组索引越界
并且不确定从哪里开始，因为我尝试重新定义阵列。
我收到了错误：Set SubFolder = Inbox.Folders(folder)
当我修改我的代码时，如果文件的附件不是。
，则会发生错误这是原始的排序代码：
If InStr(UCase(Message.Body), "OUT OF THE OFFICE") Or InStr(UCase(Message.Body), "OUT OF OFFICE") Then
folder = "Ignore"
ElseIf Message.Subject = "Secure Message Received" Then
folder = "SecureMessageReceived"
ElseIf response = "YES" Then
folder = "No changes"
ElseIf response = "NO" And newEmail <> "" Then
folder = "ToBeLoaded"
ElseIf response = "NO" And newEmail = "" Then
folder = "ToBeReviewed"
ElseIf response = "??" Then
folder = "ToBeFixed"
End If
它被改为这个花絮：
If response = "NO" And iAttachments = 1 Then
If newEmail <> "" Then
folder = "ToBeLoaded"
ElseIf newEmail = "" Then
folder = "ToBeWorked"
End If
ElseIf response = "NO" And iAttachments = 0 Then
If newEmail <> "" Then
folder = "ToBeReviewed"
ElseIf newEmail = "" Then
folder = "ToBeReviewed"
End If
End If
If InStr(UCase(Message.Body), "OUT OF THE OFFICE") Or InStr(UCase(Message.Body), "OUT OF OFFICE") Then
folder = "Ignore"
ElseIf Message.Subject = "Secure Message Received" Then
folder = "SecureMessages"
End If
这里的代码会出错：
Set SubFolder = inbox.Folders(folder)
然后给我440 Array Index of Bounds错误。
完整的参考代码：
Dim objXLApp
Dim myRegExp
Function GetInbox(MailboxName As String)
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim InboxFolder As folder
Dim MainFolder As folder
Dim SubFolder As folder
For Each MainFolder In Session.Folders
If MainFolder.name = MailboxName Then
For Each SubFolder In MainFolder.Folders
If SubFolder.name = "Inbox" Then
Set InboxFolder = SubFolder
End If
Next
End If
Next
Set GetInbox = InboxFolder 'objFolder
End Function
Public Sub ProcessAll_test()
Dim InboxFolder As folder
Dim Message
Dim MailboxName As String
Dim i
Set myRegExp = New RegExp
myRegExp.IgnoreCase = True
myRegExp.Global = True
myRegExp.Pattern = "[a-z0-9\.\-\_]+\@[a-z0-9\.\-]+\.[a-z]+"
MailboxName = "test"
Set InboxFolder = GetInbox(MailboxName)
If Not InboxFolder Is Nothing Then
Set emailList = CreateObject("System.Collections.ArrayList")
'For Each Message In InboxFolder.Items
For i = InboxFolder.Items.Count To 1 Step -1 'Iterates from the end backwards
Set Message = InboxFolder.Items(i)
If TypeName(Message) = "MailItem" Then
ProcessOne Message, InboxFolder
End If
Next
End If
End Sub
Public Sub ProcessOne(Message, inbox)
Dim Pos, id, vals, name, email, response, attachment
Dim i
'Dim oMail As Object
Dim iAttachments As Integer
'Dim inbox As Object
'Set attachment = Application.CreateItem(olMailItem)
Pos = InStr(Message.Body, "place X here:")
If Len(Message.Subject) > 0 Then
vals = Split(Message.Subject, " ")
id = vals(UBound(vals))
Else
id = "No_Subject"
End If
name = Message.Sender.name
email = Message.Sender.Address
response = ""
newEmail = ""
RecDate = Message.ReceivedTime
'inbox = Folders("testfolder").Folders("Inbox")
If Pos > 0 Then
x = UCase(Mid(Message.Body, Pos + 23, 20))
Pos = InStr(x, "X")
If Pos > 0 Then
response = "YES"
Else
Pos = 1
Do While Pos <> 0
Pos = InStr(Pos + 1, Message.Body, "@")
If Pos <> 0 Then
posA = InStrRev(Message.Body, " ", Pos)
posB = InStr(Pos, Message.Body, " ")
emailSection = Mid(Message.Body, posA + 1, posB - posA - 1)
anotherEmail = ""
Set myMatches = myRegExp.Execute(emailSection)
For Each myMatch In myMatches
anotherEmail = myMatch.Value
Next
If anotherEmail <> "test@test.com" Then
newEmail = anotherEmail
End If
End If
Loop
response = "NO"
End If
Else
response = "??"
End If
'Move email items
iAttachments = attachmentscount
'For i = iAttachments - 1 To 1 Step -1
'For i = 0 To iAttachments - 1
'If iAttachments = olMail Then
If response = "NO" And iAttachments = 1 Then
If newEmail <> "" Then
folder = "ToBeLoaded"
ElseIf newEmail = "" Then
folder = "ToBeWorked"
End If
ElseIf response = "NO" And iAttachments = 0 Then
If newEmail <> "" Then
folder = "ToBeReviewed"
ElseIf newEmail = "" Then
folder = "ToBeReviewed"
End If
End If
If InStr(UCase(Message.Body), "OUT OF THE OFFICE") Or InStr(UCase(Message.Body), "OUT OF OFFICE") Then
folder = "Ignore"
ElseIf Message.Subject = "Secure Message Received" Then
folder = "SecureMessages"
End If
WriteFile id, name, email, response, newEmail, RecDate, folder
Set SubFolder = inbox.Folders(folder)
'Next i
Message.UnRead = True
Message.Move SubFolder
End Sub
Sub WriteFile(id, name, email, response, newEmail, RecDate, folder)
Set WshShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
FileName = fso.BuildPath(WshShell.SpecialFolders("Desktop"), "test_" & Format(Date, "MMddyyyy") & ".xls")
Dim Content As String
' Create an excel object if there is not one already.
If objXLApp = Empty Then
Set objXLApp = CreateObject("Excel.Application")
End If
' Create or open existing file.
objXLApp.DisplayAlerts = False
If fso.FileExists(FileName) Then
Set objXLWb = objXLApp.Workbooks.Open(FileName)
Else
Set objXLWb = objXLApp.Workbooks.Add()
End If
Set objXLWs = objXLWb.Worksheets(1)
' Add one row to the excel.
With objXLWs
CurrentRow = 2
While .Cells(CurrentRow, 2).Value <> ""
CurrentRow = CurrentRow + 1
Wend
.Cells(1, 1).Value = "ID"
.Cells(1, 2).Value = "Name"
.Cells(1, 3).Value = "Email"
.Cells(1, 4).Value = "Response"
.Cells(1, 5).Value = "New Email"
.Cells(1, 6).Value = "RecDate"
.Cells(1, 7).Value = "Folder"
.Cells(CurrentRow, 1).Value = id
.Cells(CurrentRow, 2).Value = name
.Cells(CurrentRow, 3).Value = email
.Cells(CurrentRow, 4).Value = response
.Cells(CurrentRow, 5).Value = newEmail
.Cells(CurrentRow, 6).Value = RecDate
.Cells(CurrentRow, 7).Value = folder
End With
objXLWb.SaveAs FileName, True
objXLWb.Close
End Sub
特别是，我将在代码的这一部分得到错误：
iAttachments = attachmentscount
'For i = iAttachments - 1 To 1 Step -1
'For i = 0 To iAttachments - 1
'If iAttachments = olMail Then
If response = "NO" And iAttachments = 1 Then
If newEmail <> "" Then
folder = "ToBeLoaded"
ElseIf newEmail = "" Then
folder = "ToBeWorked"
End If
ElseIf response = "NO" And iAttachments = 0 Then
If newEmail <> "" Then
folder = "ToBeReviewed"
ElseIf newEmail = "" Then
folder = "ToBeReviewed"
End If
End If
If InStr(UCase(Message.Body), "OUT OF THE OFFICE") Or InStr(UCase(Message.Body), "OUT OF OFFICE") Then
folder = "Ignore"
ElseIf Message.Subject = "Secure Message Received" Then
folder = "SecureMessages"
End If
WriteFile id, name, email, response, newEmail, RecDate, folder
Set SubFolder = inbox.Folders(folder)
'Next i
Message.UnRead = True
Message.Move SubFolder
End Sub
答案 0 :(得分：0)
未重新创建数组索引超出范围错误。
使用以下内容，您可以确定或修正错误。
Option Explicit
Private Sub ProcessOne_test()
Dim inbx As folder
Dim mItm As mailItem
Set inbx = Session.GetDefaultFolder(olFolderInbox)
Set mItm = ActiveInspector.currentItem
ProcessOne mItm, inbx
End Sub
Public Sub ProcessOne(Message, Inbox)
Dim Pos, id, vals, name, email, response, attachment
Dim iAttachments As Integer
Dim i
Dim newEmail As String
Dim recdate As Date
Dim folder As String
Dim subFolder As folder
Pos = InStr(Message.body, "please place an X here:")
If Len(Message.subject) > 0 Then
vals = Split(Message.subject, " ")
id = vals(UBound(vals))
Else
id = "No_Subject"
End If
name = Message.sender.name
email = Message.sender.Address
response = ""
newEmail = ""
recdate = Message.ReceivedTime
'iAttachments = AttachmentCount
iAttachments = Message.Attachments.count
'Move email items
For i = 1 To iAttachments - 1
' Appears irrelevant
Next i
If iAttachments >= 1 Then
If response = "NO" And newEmail <> "" Then
folder = "ToBeLoaded"
'ElseIf reponse = "NO" And newEmail = "" Then
ElseIf response = "NO" And newEmail = "" Then
folder = "ToBeWorked"
End If
ElseIf iAttachments = 0 Then
'If reponse = "No" And newEmail <> "" Then
If response = "No" And newEmail <> "" Then
folder = "ToBeReviewed"
'ElseIf reponse = "NO" And newEmail = "" Then
ElseIf response = "NO" And newEmail = "" Then
folder = "ToBeReviewed"
End If
End If
If InStr(UCase(Message.body), "OUT OF THE OFFICE") Or InStr(UCase(Message.body), "OUT OF OFFICE") Then
folder = "Ignore"
ElseIf Message.subject = "Secure Message Received" Then
folder = "SecureMessages"
End If
'WriteFile id, name, email, response, newEmail, recdate, folder
If folder <> "" Then
On Error Resume Next
Set subFolder = Inbox.folders(folder)
On Error GoTo 0
If subFolder Is Nothing Then
MsgBox "Subfolder " & folder & " not directly under " & Inbox.name & "." & _
vbCr & vbCr & "Message not moved."
Else
Message.unread = True
Message.move subFolder
MsgBox "Message moved to " & folder & "."
End If
Else
MsgBox "No folder assigned. Message not moved."
End If
End Sub
答案 1 :(得分：0)
好的，谢谢大家的建议。我懂了。
它基本上是给文件夹命令以及如何处理消息。
我使用了nitron的代码并对其进行了稍微修改，但这似乎可以解决问题。
所以在WriteFile行下面，我添加了这个：
If folder <> "" Then
On Error Resume Next
Set subFolder = Inbox.Folders(folder)
On Error GoTo 0
If subFolder Is Nothing Then
Message.UnRead = True
Message.Move subFolder
Else
Message.UnRead = True
Message.Move subFolder
End If
End If
虽然将Message.Unread和Move两次看似多余，但它似乎已经开始了。
答案 2 :(得分：0)
这可能是与宏中未链接Outlook对象库相关的错误。 （对于另一个项目，我有相同的数组索引越界错误。）
通过工具->引用->选中“ Microsoft Outlook X.0对象库”，然后按“确定”。