Looping through mailitems in Outlook macro freezes Outlook in large sets of mailItems

穿精又带淫゛_ 提交于 2020-06-29 03:33:29

问题


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?

I have implemented:

  • Date filtering
  • MailItem release

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


回答1:


Restrict and Find/FindNext methods are run on the main thread which means they block the UI and the overall user experience with Outlook. Moreover, iterating over all folder and subfolders is not really a good idea for searching items. That is for AdvancedSearch was introduced!

The key benefits of using the AdvancedSearch method in Outlook are:

  • The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
  • Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
  • Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
  • You can stop the search process at any moment using the Stop method of the Search class.

Read more about the AdvancedSearch method in the Advanced search in Outlook programmatically: C#, VB.NET article.

Using the Scope parameter, you can specify one or more folders in the same store, but you may not specify multiple folders in multiple stores. To specify multiple folders in the same store for the Scope parameter, use a comma character between each folder path and enclose each folder path in single quotes. For default folders such as Inbox or Sent Items, you can use the simple folder name instead of the full folder path.

You can run multiple searches simultaneously by calling the AdvancedSearch method in successive lines of code. However, you should be aware that programmatically creating a large number of search folders can result in significant simultaneous search activity that would affect the performance of Outlook, especially if Outlook conducts the search in online Exchange mode.

Public m_SearchComplete As Boolean  
  
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)  
    If SearchObject.Tag = "MySearch" Then  
        m_SearchComplete = True  
    End If  
End Sub  
  
Sub TestSearchForMultipleFolders()  
    Dim Scope As String  
    Dim Filter As String  
    Dim MySearch As Outlook.Search  
    Dim MyTable As Outlook.Table  
    Dim nextRow As Outlook.Row  
    m_SearchComplete = False  
    'Establish scope for multiple folders  
    Scope = "'" & Application.Session.GetDefaultFolder( _  
    olFolderInbox).FolderPath _  
    & "','" & Application.Session.GetDefaultFolder( _  
    olFolderSentMail).FolderPath & "'"  
    'Establish filter  
    If Application.Session.DefaultStore.IsInstantSearchEnabled Then  
        Filter = Chr(34) & "urn:schemas:httpmail:subject" _  
        & Chr(34) & " ci_phrasematch 'Office'"  
    Else  
        Filter = Chr(34) & "urn:schemas:httpmail:subject" _  
        & Chr(34) & " like '%Office%'"  
    End If  
    Set MySearch = Application.AdvancedSearch( _  
    Scope, Filter, True, "MySearch")  
    While m_SearchComplete <> True  
        DoEvents  
    Wend  
    Set MyTable = MySearch.GetTable  
    Do Until MyTable.EndOfTable  
        Set nextRow = MyTable.GetNextRow()  
        Debug.Print nextRow("Subject")  
    Loop  
End Sub



回答2:


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


来源:https://stackoverflow.com/questions/62572445/looping-through-mailitems-in-outlook-macro-freezes-outlook-in-large-sets-of-mail

易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!