Поиск в общей папке ограничен 250 в Outlook

На работе мы используем 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 protected]")
 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 protected]")
 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 просмотров: тогда он останавливается.

Есть ли какое-то решение, чтобы избежать остановки поиска? Я не являюсь администратором этой общей папки, поэтому у меня нет прав на настройки.

Дерево папок:

введите здесь описание изображения


outlook vba outlook-2016 outlook-filter
person donmichael    schedule 09.03.2018    source источник

Ответы (1)


arrow_upward
0
arrow_downward

Ваш 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%'"

введите здесь описание изображения

Если у вас возникли проблемы с работой с общей папкой, вы можете использовать Свойство CurrentFolder, представляющее текущую папку, отображаемую в проводнике

В приведенном ниже примере есть цикл только для тестирования — удален, если он не нужен

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
person 0m3r    schedule 10.03.2018
comment
С Set SubFolder = ShareInbox.folders("SomeSubFolder") (без Parent) у меня ошибка времени выполнения -2147221233 (8004010f) Попытка операции не удалась. Не удалось найти объект. - person donmichael; 10.03.2018
comment
@donmichael Вы обновили имя папки SomeSubFolder? - person 0m3r; 10.03.2018
comment
Да, я обновил его до точного названия папки. - person donmichael; 10.03.2018
comment
@donmichael, можешь опубликовать изображение дерева папок Outlook? - person 0m3r; 10.03.2018
comment
Я добавил изображение, однако оно работало с решением Parent и for или foreach . - person donmichael; 10.03.2018