Outlook宏运行250次迭代，然后失败，并显示错误

推荐答案感谢@ 76mel，感谢他的回答另一个我已大量提及的问题.我发现这是Outlook中的内置限制(源)，您可以'不能打开250多个项目，Outlook会将它们全部保留在内存中，直到无论宏如何结束为止.解决方法，而不是遍历选择中的每个项目:Thanks to @76mel, for his answer to another question which I referenced heavily. I found out that it is a built-in limitation in Outlook (source) that you can't open more than 250 items and Outlook keeps them all in memory until the macro ends no matter what. The workaround, instead of looping through each item in selection:For Each objItem In Application.ActiveExplorer.Selection您可以循环浏览父文件夹.我以为我可以做这样的事情:you can loop through the parent folder. I thought I could do something like this:For Each objItem In oFolder.Items但是，事实证明，当您删除或移动电子邮件时，它会将列表上移一个，因此它将跳过电子邮件.遍历在另一个答案中找到的文件夹的最佳方法是执行以下操作:but, it turns out that when you delete or move an email, it shifts the list up one, so it will skip emails. The best way to iterate through a folder that I found in another answer is to do this:For i = oFolder.Items.Count To 1 Step -1 'Iterates from the end backwardsSet objItem = oFolder.Items(i)这是整个代码，它提示您选择要分析的文件夹，并在该文件夹中创建子目录以供外出"答复以及特殊情况"，其中将所有以"RE"开头的电子邮件:" Here is the whole code, which prompts for a folder to choose to parse, creates sub-directories in that folder for "Out of Office" replies as well as "Special Cases" where it puts all emails that begin with "RE:"Sub SaveItemsToExcel() Debug.Print "Begin SaveItemsToExcel" Dim oNameSpace As Outlook.NameSpace Set oNameSpace = Application.GetNamespace("MAPI") Dim oFolder As Outlook.MAPIFolder Set oFolder = oNameSpace.PickFolder Dim IsFolderSpecialCase As Boolean Dim IsFolderOutofOffice As Boolean IsFolderSpecialCase = False IsFolderOutofOffice = False 'If they don't check a folder, exit. If oFolder Is Nothing Then GoTo ErrorHandlerExit ElseIf oFolder.DefaultItemType <> olMailItem Then 'Make sure folder is not empty MsgBox "Folder does not contain mail messages" GoTo ErrorHandlerExit End If 'Checks to see if Special Cases Folder and Out of Office folders exists. If not, create them For i = 1 To oFolder.Folders.Count If oFolder.Folders.Item(i).name = "Special Cases" Then IsFolderSpecialCase = True If oFolder.Folders.Item(i).name = "Out of Office" Then IsFolderOutofOffice = True Next If Not IsFolderSpecialCase Then oFolder.Folders.Add ("Special Cases") If Not IsFolderOutofOffice Then oFolder.Folders.Add ("Out of Office") 'Asks user for name and location to save the export objOutputFile = CreateObject("Excel.application").GetSaveAsFilename(InitialFileName:="TestExport" & Format(Now, "_yyyymmdd"), fileFilter:="Outlook Message (*.csv), *.csv", Title:="Export data to:") If objOutputFile = False Then Exit Sub Debug.Print " Will save to: " & objOutputFile & Chr(10) 'Overwrite outputfile, with new headers. Open objOutputFile For Output As #1 Print #1, "User ID,Last Name,First Name,Company Name,Subject,Vote Response,Recived" ProcessFolderItems oFolder, objOutputFile Close #1 Set oFolder = Nothing Set oNameSpace = Nothing Set objOutputFile = Nothing Set objFS = Nothing MsgBox "All complete! Emails requiring attention are in the " & Chr(34) & "Special Cases" & Chr(34) & " subdirectory." Debug.Print "End SaveItemsToExcel." Exit SubErrorHandlerExit: Debug.Print "Error in code."End SubSub ProcessFolderItems(oParentFolder, ByRef objOutputFile) Dim oCount As Integer Dim oFolder As Outlook.MAPIFolder Dim MessageVar As String oCount = oParentFolder.Items.Count Dim CountVar As Integer Dim objItem As Outlook.MailItem CountVar = 0 For i = oParentFolder.Items.Count To 1 Step -1 'Iterates from the end backwards Set objItem = oParentFolder.Items(i) DoEvents If objItem.Class = olMail Then If objItem.VotingResponse <> "" Then CountVar = CountVar + 1 Debug.Print " " & CountVar & ". " & GetUsername(objItem.SenderName, objItem.SenderEmailAddress) & "," & objItem.SenderName & "," & GetCompany(objItem.SenderName) & "," & Replace(objItem.Subject, ",", "") & "," & objItem.VotingResponse & "," & objItem.ReceivedTime Print #1, GetUsername(objItem.SenderName, objItem.SenderEmailAddress) & "," & objItem.SenderName & "," & GetCompany(objItem.SenderName) & "," & Replace(objItem.Subject, ",", "") & "," & objItem.VotingResponse & "," & objItem.ReceivedTime ElseIf objItem.Subject Like "*Out of Office*" Then CountVar = CountVar + 1 Debug.Print " " & CountVar & ". " & "Moving email from: " & Chr(34) & objItem.SenderName & Chr(34) & " to the, " & Chr(34) & "Out of Office" & Chr(34) & " sub-folder" objItem.Move oParentFolder.Folders("Out of Office") Else CountVar = CountVar + 1 Debug.Print " " & CountVar & ". " & "Moving email from: " & Chr(34) & objItem.SenderName & Chr(34) & " to the, " & Chr(34) & "Special Cases" & Chr(34) & " sub-folder" objItem.Move oParentFolder.Folders("Special Cases") End If End If Next i Set objItem = NothingEnd SubFunction GetUsername(SenderNameVar As String, SenderEmailVar As String) As String On Error Resume Next GetUsername = "" GetUsername = CreateObject("Outlook.Application").CreateItem(olMailItem).Recipients.Add(SenderNameVar).AddressEntry.GetExchangeUser.Alias If GetUsername = "" Then GetUsername = Mid(SenderEmailVar, InStrRev(SenderEmailVar, "=", -1) + 1)End FunctionFunction GetCompany(SenderNameVar) On Error Resume Next GetCompany = "" GetCompany = CreateObject("Outlook.Application").CreateItem(olMailItem).Recipients.Add(SenderNameVar).AddressEntry.GetExchangeUser.CompanyNameEnd Function 这篇关于Outlook宏运行250次迭代，然后失败，并显示错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！