Outlook VBA中遍历Table为何比遍历Folder快5倍？

我在包含220个项目的Outlook文件夹上运行代码时发现：当sLoopThru设为"folder"时，每秒只能输出34行数据；设为"table"时，每秒输出跃升至165行，速度差了5倍。想知道为什么Table遍历会快这么多？
我更倾向用Folder遍历（如果能提速的话），因为它能提供更多信息——比如代码里Folder遍历可以获取附件数量，而Table只能判断是否存在附件。

Sub pOutlookEmailPropertiesToExcel(sExcelPath As String, sExcelFile As String, _
                                   sExcelSheet As String, bNewFile As Boolean, _
                                   oOutlookFolder As MAPIFolder, sLoopThru As String, bTimeIt As Boolean)

' Output properties of e-mails in the given Outlook folder to Excel.

' sLoopThru = "folder" or "table"

' This code requires "Tools > References > Microsoft Excel ___ Object Library": Check.
' The workbook is opened in a new instance of Excel.

' The following line appears three times. It finds the last row with a value in column A,
'       then adds 1 to get number of the first empty row. This allows this routine to be called multiple
'       times to collect data on a series of folders (bNewFile false after first one).
'   nRowNext = oExcelSheet.Cells(oExcelSheet.Rows.Count, "A").End(xlUp).Row + 1

' Adapted from example code at:
'   https://learn.microsoft.com/en-us/office/vba/api/outlook.folder.gettable
' and subs AnswerD(), AnswerF1(), AnswerF2(), and AnswerG() in SO answer by Tony Dallimore:
'   www.stackoverflow.com/questions/8697493/update-excel-sheet-based-on-outlook-mail/#8699250

Dim oExcelApp As Excel.Application, oExcelFile As Excel.Workbook, oExcelSheet As Excel.Worksheet, _
    nRowNext As Long, _
    oEmailItem As Object, nEmailItemClass As Integer, _
    oOutlookTable As Outlook.Table, oTableRow As Outlook.Row, _
    nCounter As Long

Set oExcelApp = Application.CreateObject("Excel.Application")
oExcelApp.Visible = True         ' Dallimore: "This slows your macro but helps during debugging."
If (bNewFile) Then
    Set oExcelFile = oExcelApp.Workbooks.Add
  Else
    Set oExcelFile = oExcelApp.Workbooks.Open(sExcelPath & sExcelFile)
  End If
Set oExcelSheet = oExcelFile.Sheets(sExcelSheet)

' ***** Set up table and its columns.
If sLoopThru = "table" And (oOutlookFolder.DefaultItemType = olMailItem) Then
    Set oOutlookTable = oOutlookFolder.GetTable("[CreationTime] <> '0'")    ' This filter includes all.
    With oOutlookTable.Columns
        .Add ("SenderName"): .Add ("SenderEmailAddress"): .Add ("SenderEmailType"): .Add ("SentOnBehalfOfName")
        .Add ("To"): .Add ("CC"): .Add ("BCC")
        .Add ("Size"):
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B")    ' PR_HASATTACH
        ' .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E13000D")    ' PR_MESSAGE_ATTACHMENTS
            ' This adds without error, but output of it is empty.
        .Add ("SentOn"): .Add ("ReceivedTime")
        .Add ("DeferredDeliveryTime"): .Add ("ReminderTime"): .Add ("ExpiryTime")
        .Add ("Unread")
      End With
  End If    ' sLoopThru = "table"

' ***** Output Excel header rows.
oExcelSheet.Range("A1").Value = "Properties of e-mail items in Outlook folder"
oExcelSheet.Range("A3:Y3").Value = _
    Array("Folder", "Subfolders", "Items", "Item", "EntryID", "MessageClass", _
          "SenderName", "SenderEmailAddress", "SenderEmailType", "SentOnBehalfOfName", _
          "To", "CC", "BCC", "Subject", "Size", "Attachments", _
          "SentOn", "ReceivedTime", "CreationTime", "LastModificationTime", _
          "DeferredDeliveryTime", "ReminderTime", "ExpiryTime", "Unread", "Error")
If (bTimeIt) Then oExcelSheet.Range("Z3").Value = "Timestamp"

' ***** Output data on folder.
nRowNext = oExcelSheet.Cells(oExcelSheet.Rows.Count, "A").End(xlUp).Row + 1
oExcelSheet.Range("A" & nRowNext & ":C" & nRowNext).Value = _
        Array(oOutlookFolder.Name, oOutlookFolder.Folders.Count, oOutlookFolder.Items.Count)

' ***** Loop through items and output properties to Excel.
If (oOutlookFolder.DefaultItemType = olMailItem) Then
    Select Case sLoopThru
        Case "folder":
            For nCounter = 1 To oOutlookFolder.Items.Count
                Set oEmailItem = oOutlookFolder.Items.Item(nCounter)
                ' Dallimore tests oEmailItem.Class here, says it seems to avoid syncronisation errors.
                nRowNext = oExcelSheet.Cells(oExcelSheet.Rows.Count, "A").End(xlUp).Row + 1
                On Error GoTo ExcelError
                oExcelSheet.Range("A" & nRowNext & ":X" & nRowNext).Value = _
                    Array(oOutlookFolder.Name, , , nCounter, _
                          oEmailItem.EntryID, oEmailItem.MessageClass, _
                          oEmailItem.SenderName, oEmailItem.SenderEmailAddress, oEmailItem.SenderEmailType, _
                          oEmailItem.SentOnBehalfOfName, _
                          oEmailItem.To, oEmailItem.CC, oEmailItem.BCC, oEmailItem.Subject, _
                          oEmailItem.Size, oEmailItem.Attachments.Count, _
                          oEmailItem.SentOn, oEmailItem.ReceivedTime, oEmailItem.CreationTime, _
                          oEmailItem.LastModificationTime, oEmailItem.DeferredDeliveryTime, _
                          oEmailItem.ReminderTime, oEmailItem.ExpiryTime, oEmailItem.UnRead)
                On Error GoTo 0
                If (bTimeIt) Then oExcelSheet.Range("Z" & nRowNext).Value = Now()
              Next nCounter
        Case "table":
            nCounter = 0
            Do Until (oOutlookTable.EndOfTable)
                nCounter = nCounter + 1
                Set oTableRow = oOutlookTable.GetNextRow()
                nRowNext = oExcelSheet.Cells(oExcelSheet.Rows.Count, "A").End(xlUp).Row + 1
                On Error GoTo ExcelError
                oExcelSheet.Range("A" & nRowNext & ":X" & nRowNext).Value = _
                    Array(oOutlookFolder.Name, , , nCounter, _
                        oTableRow("EntryID"), oTableRow("MessageClass"), _
                        oTableRow("SenderName"), oTableRow("SenderEmailAddress"), oTableRow("SenderEmailType"), _
                        oTableRow("SentOnBehalfOfName"), _
                        oTableRow("To"), oTableRow("CC"), oTableRow("BCC"), oTableRow("Subject"), _
                        oTableRow("Size"), _
                        oTableRow("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"), _
                        oTableRow("SentOn"), oTableRow("ReceivedTime"), oTableRow("CreationTime"), _
                        oTableRow("LastModificationTime"), oTableRow("DeferredDeliveryTime"), _
                        oTableRow("ReminderTime"), oTableRow("ExpiryTime"), oTableRow("Unread"))
                On Error GoTo 0
                If (bTimeIt) Then oExcelSheet.Range("Z" & nRowNext).Value = Now()
              Loop
      End Select    ' sLoopThru
  End If            ' oOutlookFolder.DefaultItemType = olMailItem

If (bNewFile) Then
    oExcelFile.SaveAs (sExcelPath & sExcelFile)
  Else
    oExcelFile.Save
  End If
oExcelFile.Close
oExcelApp.Quit           ' Dallimore's code does this only for bNewFile true.

Exit Sub

ExcelError:
    oExcelSheet.Range("Y" & nRowNext).Value = "Error " & Err.Number & _
                                              " (" & Err.Description & ") from " & Err.Source
    Resume Next

End Sub     ' pOutlookEmailPropertiesToExcel()

• 对象实例化开销：Folder遍历每次循环都要通过Items.Item(nCounter)创建完整的MailItem对象实例，这个过程会加载邮件的所有属性（哪怕你只用到其中一部分），而且每次访问属性都可能触发和Outlook MAPI层的交互，开销极大。
• 批量数据读取：Table是Outlook提供的高效数据查询接口，它会一次性预加载你指定的所有列属性，直接从邮件存储中读取数据，不需要逐个创建MailItem对象，减少了大量COM对象的创建和销毁开销。
• 避免不必要的加载：Table只返回你指定的属性，而Folder遍历的MailItem会加载所有内置和自定义属性，哪怕你用不到，额外的加载操作拖慢了速度。

针对你的需求，以下优化点能大幅提升Folder遍历速度：

1. 缓存Items集合并排序
   不要每次循环都调用oOutlookFolder.Items，提前缓存集合并排序，减少Outlook内部索引开销：

Dim oItems As Outlook.Items
Set oItems = oOutlookFolder.Items
oItems.Sort "[CreationTime]" ' 排序后访问更高效

2. 关闭Excel屏幕更新
   Excel可见状态下每次写入都会刷新屏幕，这是主要的速度瓶颈之一，写入前关闭屏幕更新，最后恢复：

oExcelApp.ScreenUpdating = False
' ... 遍历写入代码 ...
oExcelApp.ScreenUpdating = True

3. 避免重复查找最后一行
   每次调用Cells(Rows.Count, "A").End(xlUp).Row都会扫描整列，耗时极高，提前记录起始行后直接递增：

nRowNext = oExcelSheet.Cells(oExcelSheet.Rows.Count, "A").End(xlUp).Row + 1
For nCounter = 1 To oItems.Count
    ' ... 写入代码 ...
    nRowNext = nRowNext + 1 ' 直接递增行号，无需重复查找
Next

4. 用PropertyAccessor获取附件数量
   替换Attachments.Count，通过MAPI属性直接读取附件数量，避免实例化Attachments集合：

Dim propAccessor As Outlook.PropertyAccessor
Set propAccessor = oEmailItem.PropertyAccessor
Dim attachCount As Long
attachCount = propAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E130003")

将原代码中Case "folder"部分替换为以下内容：

Case "folder":
    Dim oItems As Outlook.Items
    Set oItems = oOutlookFolder.Items
    oItems.Sort "[CreationTime]" ' 排序优化访问速度
    oExcelApp.ScreenUpdating = False ' 关闭Excel屏幕更新
    nRowNext = oExcelSheet.Cells(oExcelSheet.Rows.Count, "A").End(xlUp).Row + 1 ' 提前获取起始行
    
    For nCounter = 1 To oItems.Count
        Set oEmailItem = oItems.Item(nCounter)
        On Error GoTo ExcelError
        
        ' 用PropertyAccessor获取附件数量，替代Attachments.Count
        Dim propAccessor As Outlook.PropertyAccessor
        Set propAccessor = oEmailItem.PropertyAccessor
        Dim attachCount As Long
        attachCount = propAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E130003")
        
        oExcelSheet.Range("A" & nRowNext & ":X" & nRowNext).Value = _
            Array(oOutlookFolder.Name, , , nCounter, _
                  oEmailItem.EntryID, oEmailItem.MessageClass, _
                  oEmailItem.SenderName, oEmailItem.SenderEmailAddress, oEmailItem.SenderEmailType, _
                  oEmailItem.SentOnBehalfOfName, _
                  oEmailItem.To, oEmailItem.CC, oEmailItem.BCC, oEmailItem.Subject, _
                  oEmailItem.Size, attachCount, _
                  oEmailItem.SentOn, oEmailItem.ReceivedTime, oEmailItem.CreationTime, _
                  oEmailItem.LastModificationTime, oEmailItem.DeferredDeliveryTime, _
                  oEmailItem.ReminderTime, oEmailItem.ExpiryTime, oEmailItem.UnRead)
        On Error GoTo 0
        
        If (bTimeIt) Then oExcelSheet.Range("Z" & nRowNext).Value = Now()
        nRowNext = nRowNext + 1 ' 直接递增行号
    Next nCounter
    
    oExcelApp.ScreenUpdating = True ' 恢复屏幕更新

内容的提问来源于stack exchange，提问作者NewSites