在Outlook中搜索限制为250的共享文件夹

Question

在工作中，我们使用Outlook 2016，我们有一个共享文件夹。我正在尝试计算这个共享文件夹的subfolder中包含指定文本的电子邮件的数量。我有一个解决方案，但太慢了(一个月有数千封电子邮件)。

我的第一个解决方案是有效的：

Sub SearchBody()
 Dim myItems As Outlook.Items
 Dim ShareInbox As Outlook.MAPIFolder
 Dim myNamespace As Outlook.NameSpace
 Dim myRecipient As Outlook.Recipient
 Dim SubFolder As Object
 Dim i As Integer
 Dim myRestrictItems As Outlook.Items
 Dim myItem As Object
 Dim z As Integer
 Dim dateStart As Date


 i = 0
 dateStart = DateTime.now    

 Set myNamespace = Application.GetNamespace("MAPI")
 Set myRecipient = myNamespace.CreateRecipient("email@email.com")
 Set ShareInbox = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
 Set SubFolder = ShareInbox.Parent.Folders("SomeSubFolder")
 Set myItems = SubFolder.Items
 Set myRestrictItems = myItems.Restrict("[SentOn]>='2/1/2018' AND [SentOn]<'3/1/2018'")

 For z = myRestrictItems.Count To 1 Step -1
     If InStr(1, myRestrictItems(z).Body, "SomeStringToSearch") > 0 Then
         i = i + 1
     End If
 Next

 MsgBox i & vbNewLine & Format(DateTime.now - dateStart, "hh:mm:ss")
End Sub

所以它是有效的，但太慢了(7-10分钟)。

我的下一个代码是：

Sub SearchBody2()
 Dim table As Outlook.table
 Dim filter As String
 Dim myNamespace As Outlook.NameSpace
 Dim myRecipient As Outlook.Recipient
 Dim ShareInbox As Outlook.MAPIFolder
 Dim SubFolder As Object
 Dim row As Outlook.row
 Dim myRestrictItems As Outlook.Items
 Dim myItems As Outlook.Items

 filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%SomeStringToSearch%'"

 Set myNamespace = Application.GetNamespace("MAPI")
 Set myRecipient = myNamespace.CreateRecipient("email@email.com")
 Set ShareInbox = myNamespace.GetSharedDefaultFolder(myRecipient,      olFolderInbox)
 Set SubFolder = ShareInbox.Parent.Folders("SomeSubFolder")


 Set table = SubFolder.GetTable(filter, Outlook.OlTableContents.olUserItems)

 MsgBox table.GetRowCount

End Sub

(我知道在这段代码中没有像第一个代码那样的日期过滤器)这也是有效的，直到它达到250次点击:它停止。

有什么解决方案可以避免搜索停止吗？我不是此共享文件夹的管理员，因此我没有设置权限。

文件夹树：

​

​

Answer 1

您的SubFolder应为Set SubFolder = ShareInbox.folders("SomeSubFolder")

要将日期添加到您的筛选器，则示例如下

     filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
                        Chr(34) & " >= '02/01/2018' And " & _
                        Chr(34) & "urn:schemas:httpmail:datereceived" & _
                        Chr(34) & " < '02/28/2018' And " & _
                        Chr(34) & "urn:schemas:httpmail:textdescription" & _
                        Chr(34) & "Like '%SomeStringToSearch%'"

​

​

如果您在使用共享文件夹时遇到问题，您可以使用，它代表资源管理器中显示的当前文件夹

下面的示例有循环，只是为了测试-如果不需要就删除它

Option Explicit
Public Sub Example()
    Dim TargetFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim i As Long

    If TargetFolder Is Nothing Then Set TargetFolder = ActiveExplorer.CurrentFolder
    Debug.Print TargetFolder.Name

    Dim Filter As String
        Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
                           Chr(34) & " >= '02/01/2018' AND " & _
                           Chr(34) & "urn:schemas:httpmail:datereceived" & _
                           Chr(34) & " < '02/28/2018' AND " & _
                           Chr(34) & "urn:schemas:httpmail:textdescription" & _
                           Chr(34) & "Like '%SomeStringToSearch%'"


    Set Items = TargetFolder.Items.Restrict(Filter)

    MsgBox (Items.Count & " Items in " & TargetFolder.Name)
    Debug.Print Items.Count & " Items in " & TargetFolder.Name

    For i = Items.Count To 1 Step -1
        DoEvents
        Debug.Print Items(i).Subject 'Immediate Window
    Next

End Sub