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%'"

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

下面的示例包含仅用于测试的循环 - 如果不需要则删除

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

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

1 个答案: