展望經過250次迭代宏運行與錯誤而失敗之前

Question

說明：

我有一個Outlook宏，通過選擇郵件文件夾中的循環，並寫下一些信息爲.csv文件。它在失敗之前一直運行到250。下面是一些代碼：

Open strSaveAsFilename For Append As #1 

CountVar = 0 
For Each objItem In Application.ActiveExplorer.Selection 
    DoEvents 
    If objItem.VotingResponse <> "" Then 
     CountVar = CountVar + 1 
     Debug.Print " " & CountVar & ". " & objItem.SenderName 
     Print #1, & objItem.SenderName & "," & objItem.VotingResponse 
    Else 
     CountVar = CountVar + 1 
     Debug.Print " " & CountVar & ". " & "Moving email from: " & Chr(34) & objItem.SenderName & Chr(34) & " to: Special Cases sub-folder" 
     objItem.Move CurrentFolderVar.Folders("Special Cases") 
    End If 
Next 
Close #1 

問題

此代碼後通過電子郵件250運行，下面的截圖彈出：

http://i.stack.imgur.com/yt9P8.jpg

我試着加入一個「等待」函數讓服務器休息一下，這樣我就不會如此快速地查詢它，但是在同一點上我得到同樣的錯誤。

Answer 1

感謝@ 76mel，因爲他的answer是我另外提到的一個問題。我發現它是Outlook中的一個內置限制（source），無法打開超過250個項目，Outlook將它們全部保留在內存中，直到宏無論如何都結束。解決方法，而不是通過每一個項目中選擇循環：

For Each objItem In Application.ActiveExplorer.Selection 

你可以通過父文件夾循環。我想我可以做這樣的事情：

For Each objItem In oFolder.Items 

但是，事實證明，當你刪除或移動電子郵件，它移到列表中的一個，所以它會跳過電子郵件。通過我在another answer發現了一個文件夾，重複的最好方法是做到這一點：

For i = oFolder.Items.Count To 1 Step -1 'Iterates from the end backwards 
Set objItem = oFolder.Items(i) 

這裏是整個代碼，它會提示一個文件夾選擇來分析，該文件夾中的「創建子目錄離開辦公室「回覆，以及‘’它把那個開頭的所有電子郵件，其中包含‘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 Sub 
ErrorHandlerExit: 
    Debug.Print "Error in code." 
End Sub 

Sub 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 = Nothing 
End Sub 

Function 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 Function 

Function GetCompany(SenderNameVar) 
    On Error Resume Next 
    GetCompany = "" 
    GetCompany = CreateObject("Outlook.Application").CreateItem(olMailItem).Recipients.Add(SenderNameVar).AddressEntry.GetExchangeUser.CompanyName 
End Function 

Answer 2

爲了解決這個問題，我使用了下列規則：

的」 objOutlook.ActiveExplorer 「範圍有限（250個物體）。

但是爲每個電子郵件創建的對象是無限的。

的爲例：

sub Over250() 

    Total = objOutlook.ActiveExplorer.Selection.Count 

    For X = 1 to Total 

    Set objOutlook = CreateObject("Outlook.Application") 
    Set ObjExplorer = objOutlook.ActiveExplorer  

    '**** DO YOU THINGS**** 

    Set objOutlook = Nothing 
    Set ObjExplorer = Nothing 

    Next X 

end sub