在Outlook宏中循环浏览邮件项会冻结大量邮件项中的Outlook [英] Looping through mailitems in Outlook macro freezes Outlook in large sets of mailItems

问题描述

我试图遍历不同子文件夹的mailItems，以在不同的商店中查找注释(使用PropertyAccessor).当给定1-3个商店和大约2000个mailItems时，我的代码可以完美运行，但是随着实时测试数量的增加，它崩溃了，Outlook无法再响应了.

I am trying to loop through the mailItems of different subfolders looking for a comment (with PropertyAccessor) in different stores. My code works perfectly when given 1-3 stores and around 2000 mailItems, however as the number increases in the live testing it crashed Outlook not responding anymore.

您是否知道我该如何做得更有效?

Do you have any idea how I could do it more efficient?

我已经实现:

• 日期过滤
• MailItem发布

我正在尝试并行使用Application.AdvancedSearch方法，但是还没有进行管理.

And I am trying parallely the Application.AdvancedSearch method, however not managing yet.

 Sub FindEmaibyComment()

  Dim Fldr As Outlook.folder
  Dim Str As Outlook.Store
  Dim Strs As Outlook.Stores
  Dim Pfldr As Outlook.folder
  Dim oRoot As Outlook.folder
  Dim clearingFolder As Outlook.folder
  Dim mail As MailItem
  Dim TaskID As String
  
  
  Set Strs = Application.Session.Stores
  
 TaskID = InputBox("Enter the MailID you want to look for." & vbNewLine & "(For example MAIL_20200525_1502769)", "Message input", "")
 Set RegEx = CreateObject("vbscript.regexp")
 With RegEx
    .MultiLine = False
    .Global = True
    .IgnoreCase = True
    .Pattern = "MAIL_" & "[0-9]{8}" & "_" & "[0-9]{6,100}" ' <-- Regex match for input string, example string: MAIL_20200513_1434402
End With

Set Match = RegEx.Execute(TaskID)

If Match.Count = 1 Then
 
    'Select the stores that contain ICE, and loop through them
    For Each Str In Strs
        If InStr(Str.DisplayName, "Mailbox1") > 0 Then 
            On Error Resume Next '--> In case no permission for the store is given, go to the next store
            Set oRoot = Str.GetRootFolder
            Set clearingFolder = LoopFolders(oRoot, TaskID)
        End If
    Next Str
    If MailFound = False Then
        MsgBox ("Sorry, I could not find the Email")
    End If
    
 Else
 MsgBox ("Please insert the correct ID with a format as follows: MAIL_12345678_1234567")
End If

End Sub

Function LoopFolders(ByVal oFolder As Outlook.folder, TaskID As String) As Outlook.folder
 Dim folders As Outlook.folders
 Dim Subfolders As Outlook.folders
 Dim folder As Outlook.folder
 Dim SubFolder As Outlook.folder
 Dim foldercount As Integer
 Dim clearingFolder As Outlook.folder
 
 On Error Resume Next
 Set folders = oFolder.folders
 foldercount = folders.Count

 'Count folders below oFolder. This is the store level
 If foldercount Then
     For Each folder In folders
          
          'Count folders below Folder. This is 1. folder level "AE01"
        If folder.folders.Count > 0 Then
            Set Subfolders = folder.folders

            For Each SubFolder In Subfolders
            
            'Subfolders below Folder. This is 2. folder level "Clearing", "Destination"
                If InStr(SubFolder, "Destination") > 0 Then
                    Set LoopFolders = SubFolder
                    FindID TaskID, SubFolder

                End If
            Next SubFolder
        End If
    Next folder
 End If
End Function
Function FindID(TaskID As String, folderClearing As Outlook.folder)

Dim PropName, Comment, MessageID As String
 Dim oMail As MailItem
 Dim oPA As Outlook.PropertyAccessor
 Dim olFolder  As Outlook.MAPIFolder
 Dim olNamespace As Outlook.NameSpace
 Dim inputDate, inputDay, inputYear, inputMonth, sFilter, inputDateConverted, startDay, endDay As String

    inputDate = Right(Left(TaskID, 13), 8)  'Example: 20200610
    inputYear = Left(inputDate, 4)
    inputDay = Right(inputDate, 2)
    inputMonth = Right(Left(inputDate, 6), 2)

    If Left(inputDay, 1) = "0" Then
        inputDay = Right(inputDay, 1)
    End If
    If Left(inputMonth, 1) = "0" Then
        inputMonth = Right(inputMonth, 1)
    End If

    inputDateConverted = inputMonth & "/" & inputDay & "/" & inputYear
    startDay = Format(CDate(inputDateConverted & " 00:00 AM "), "\'m/d/yyyy hh:mm AM/PM\'")
    endDay = Format(CDate(inputDateConverted & " 12:00 PM"), "\'m/d/yyyy hh:mm AM/PM\'")
    
    Set myItems = folderClearing.Items
    sFilter = startDay & " > [ReceivedTime] And" & endDay & " < [ReceivedTime]"
    Set myRestrictedItems = myItems.Restrict(sFilter)


For Each oMail In myRestrictedItems
            'PR_TRANSPORT_COMMENTS
            PropName = "http://schemas.microsoft.com/mapi/proptag/0x3004001F"
            Set oPA = oMail.PropertyAccessor
            Comment = oPA.GetProperty(PropName)
            
             If InStr(1, Comment, TaskID, vbTextCompare) > 0 Then
                MailFound = True
                MsgBox ("Mail was found in Company Code " & folderClearing.Parent & ", let me open it for you")
                oMail.Display
                End
            End If
            Set oMail = Nothing

        Next oMail
End Function

推荐答案

神秘失败的常见原因是使用On Error Resume Next隐藏错误.

A common cause of mysterious failure is hiding errors with On Error Resume Next.

For Each Str In Strs
    
    Debug.Print "Str.DisplayName: " & Str.DisplayName
        
    If InStr(Str.DisplayName, "Mailbox1") > 0 Then
            
        Set oRoot = Nothing ' else bypssing expected error keeps previous value in oRoot
            
        ' bypass expected error
        On Error Resume Next '--> In case no permission for the store is given, go to the next store
        Set oRoot = Str.GetRootFolder
            
        ' remove error bypass
        '  to return to normal error handling
        '  to deal with unexpected errors
        On Error GoTo 0    ' now you can see errors and can debug your code

        ' Handle the bypassed error
        If Not oRoot Is Nothing Then
            Set clearingFolder = LoopFolders(oRoot, TaskID)
        End If
            
    End If
        
Next Str

这篇关于在Outlook宏中循环浏览邮件项会冻结大量邮件项中的Outlook的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！