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

为了解决这个问题，我使用了以下规则：

＆＃34; objOutlook.ActiveExplorer＆＃34;范围有限（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

Outlook宏在失败之前会运行250次迭代

2 个答案: