Excel VBA - 遍历 Outlook 文件夹的最有效方法

Question

在 Excel VBA 中遍历 Outlook.Folders 的最有效方法是什么？我对 Excel VBA 有点陌生，目前正在使用递归遍历文件夹。

以下代码有效，但有什么比我编写的代码更好的吗？

       Private Function RecursiveEmailItems( _
        Optional SubjectContains As String = Empty, _
        Optional FolderType As OlDefaultFolders = olFolderInbox, _
        Optional StartFolderNm As String = "", _
        Optional Folder As Outlook.Folder = Nothing, _
        Optional FolderDepth As Long = 1)
        
        Dim Filter As String           ' Stores outlook filter
        Dim Emails As Outlook.Items    ' Stores list of outlook emails
        Dim Email As Outlook.MailItem  ' Stores an email item
        Dim oTest As Object            ' Used to test email/folder item
        
        If SubjectContains <> "" Then Filter = "@SQL=urn:schemas:httpmail:subject ci_phrasematch '" _
            & SubjectContains & "'"
        
        '-- Check to see if need to initialize folder - First Run --
        If Folder Is Nothing Then
            If StartFolderNm = "" Then Set Folder = _
                Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(FolderType) _
            Else Set Folder = _
                Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(FolderType).Folders(StartFolderNm)
        End If
        
        '-- Get emails from the folder, use filter if not empty
        If Filter = "" Then Set Emails = Folder.Items Else Set Emails = Folder.Items.Restrict(Filter)
        
        '-- Process all emails found --
        If Emails.Count > 0 Then Debug.Print Indent(FolderDepth, " ") & "-" & Folder.Name
        For Each oTest In Emails
            If TypeName(oTest) = "MailItem" Then
                Set Email = oTest
                Debug.Print Indent(FolderDepth, " ") & " |" & Email.Subject
            End If
        Next oTest
        
        '-- Process all subfolders --
        For Each oTest In Folder.Folders
            If TypeName(oTest) = "MAPIFolder" Then
                Call RecursiveEmailItems(SubjectContains, FolderType, StartFolderNm, oTest, FolderDepth + 1)
            End If
        Next oTest
    End Function
    
    Private Function GetEmailStatus()
        'Dim Filter As String: Initialize: Filter = "Timesheet " & Format(EndDt, "mm/dd/yy")
        Dim Filter As String: Initialize: Filter = "Timesheet 06"
    
        Call RecursiveEmailItems("Timesheet 06/", olFolderInbox, "Timesheet")
    End Function
    
    Private Function Indent(Count As Long, Char As String) As String
        Dim idx As Long
        For idx = 1 To Count
            Indent = Indent + Char
        Next
    End Function

提前感谢您的帮助！

Answer 1

为每个文件夹运行Restrict 方法并不是一个好主意。相反，您可以考虑使用 Application 类的 AdvancedSearch 方法。在 Outlook 中使用 AdvancedSearch 方法的主要好处是：

• 搜索在另一个线程中执行。您无需手动运行另一个线程，因为 AdvancedSearch 方法会在后台自动运行它。
• 可以在任何位置（即超出某个文件夹的范围）搜索任何项目类型：邮件、约会、日历、便笺等。 Restrict 和 Find/FindNext 方法可以应用于特定的 Items 集合（请参阅 Outlook 中 Folder 类的 Items 属性）。
• 完全支持 DASL 查询（自定义属性也可用于搜索）。您可以在 MSDN 中的 Filtering 文章中阅读有关此内容的更多信息。为了提高搜索性能，如果为商店启用了即时搜索，则可以使用即时搜索关键字（请参阅Store 类的IsInstantSearchEnabled 属性）。
• 您可以随时使用Search 类的Stop 方法停止搜索过程。

在Advanced search in Outlook programmatically: C#, VB.NET 文章中了解有关此方法的更多信息。

  
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

要为Scope 参数指定多个文件夹，请在每个文件夹路径之间使用逗号字符并将每个文件夹路径括在单引号中。对于收件箱或已发送邮件等默认文件夹，您可以使用简单的文件夹名称而不是完整的文件夹路径。

Answer 2

我觉得这很好。你有什么特别想改进的地方吗？ 我要删除的唯一行是If TypeName(oTest) = "MAPIFolder" Then 行。 OOM 中的所有文件夹都是MAPIFolder，因此检查是多余的，但无论哪种方式，它都不会对性能产生太大影响。