vba - 根据电子邮件地址移动超过 20,000 封电子邮件会冻结 Outlook

Question

我正在尝试根据电子邮件地址将超过 20,000 封电子邮件移动到所需的文件夹中。

我发现的代码冻结了 Outlook。该代码在冻结之前确实有效。

使用此帖子答案中的第一个代码

Option Explicit
Public Sub Move_Items()
'   // Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim Items As Outlook.Items
    Dim lngCount As Long

    On Error GoTo MsgErr
'    Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

'   // Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items(lngCount)

        If Item.Class = olMail Then
            Select Case Item.SenderEmailAddress

'               // Email_One
                Case "[e-mail]"
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Folder One")
                    Set Item = Items.Find("[SenderEmailAddress] = '[e-mail]'")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If

'               // Email_Two
                Case "[e-mail]"
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Folder Two")
                    Set Item = Items.Find("[SenderEmailAddress] = '[e-mail]'")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If

            End Select
        End If
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Set Items = Nothing

    Exit Sub

'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub

是否也可以不过滤特定的电子邮件地址，例如 [e-mail] 而是 *@test.com？

标签： vbaoutlook

Answer 1

如果处理每个项目，则无需查找。Find 替换了 For 循环项。当项目较少时，它更有可能完成。

最简单的更改是删除 Find。这应该可以修复任何数组越界错误。仍然是低效的。

// Email_One
Case "[e-mail]"
    '// Set SubFolder of Inbox
    Set SubFolder = Inbox.Folders("Folder One")
    '// Mark As Read
    Item.UnRead = False
    '// Move Mail Item to sub Folder
    Item.Move SubFolder

将处理限制为适用项目的一种方法。

Option Explicit


Public Sub Move_Items_Restrict()

    '// Declare your Variables
    Dim myInbox As Folder
    Dim subFolder As Folder
    
    Dim myItem As Object
    Dim myItems As Items
    Dim resItems As Items
    
    Dim strfilter As String
    Dim i As Long

    ' Not while developing
    'On Error GoTo MsgErr
    
    ' Set Inbox Reference
    Set myInbox = Session.GetDefaultFolder(olFolderInbox)

    '// Email_One
    Set myItems = myInbox.Items
    
    strfilter = "[SenderEmailAddress] = '[e-mail]'"
    Debug.Print strfilter

    ' some of these work, fromemail does
    ' https://docs.microsoft.com/en-us/previous-versions/office/developer/exchange-server-2007/aa579702(v=exchg.80)    
    'strfilter = "@SQL=urn:schemas:httpmail:fromemail LIKE '[e-mail]'"
    'Debug.Print strfilter

    Set resItems = myItems.Restrict(strfilter)
    Debug.Print resItems.count
    
    If resItems.count > 0 Then
    
        '// Set SubFolder of Inbox
        Set subFolder = myInbox.folders("Folder One")

        For i = resItems.count To 1 Step -1
        
            Set myItem = resItems(i)
            
            With myItem
                '// Mark As Read
                .UnRead = False
                
                '// Move Mail Item to sub Folder
                .Move subFolder
            End With
            
            ' If there is a memory error,
            '  release item when no longer necessary,
            'Set myItem = Nothing
        
        Next
    
    End If
    
    
    '// Email_Two
    Set myItems = myInbox.Items
    
    strfilter = "[SenderEmailAddress] = '[e-mail]'"
    Debug.Print strfilter

    Set resItems = myItems.Restrict(strfilter)
    Debug.Print resItems.count
    
    If resItems.count > 0 Then
    
        '// Set SubFolder of Inbox
        Set subFolder = myInbox.folders("Folder Two")

        For i = resItems.count To 1 Step -1
        
            Set myItem = resItems(i)
            
            With myItem
    '           // Mark As Read
                .UnRead = False
                
    '           // Move Mail Item to sub Folder
                .Move subFolder
            End With
            
            ' If there is a memory error,
            '  release item when no longer necessary,
            'Set myItem = Nothing
        
        Next
    
    End If

MsgErr_Exit:
    Exit Sub

'// Error information for users to advise the developer
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & err.Number _
         & vbCrLf & "Error Description: " & err.description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
    
End Sub