VBA场景下如何获取Outlook资源管理器列表中选中的最顶层项目？

要直接获取Outlook资源管理器列表中显示最顶层的选中项目，不用纠结视图的复杂排序规则，可以通过以下两种可靠方法实现：

方法一：利用当前视图的排序规则对选中项排序 #

Outlook的CurrentView对象包含了当前视图的所有排序规则，你可以读取这些规则，然后对Selection集合里的项目进行排序，最终拿到显示最顶层的那一项：

Function GetTopSelectedItem() As Object
    Dim exp As Explorer
    Dim view As View
    Dim sortFields As SortFields
    Dim sortField As SortField
    Dim selectedItems As Selection
    Dim sortedItems As Collection
    Dim item As Object
    Dim i As Integer, j As Integer
    Dim compareResult As Integer
    
    Set exp = Application.ActiveExplorer
    Set selectedItems = exp.Selection
    If selectedItems.Count = 0 Then Exit Function
    
    Set view = exp.CurrentView
    Set sortFields = view.SortFields
    Set sortedItems = New Collection
    
    ' 先把选中项加入集合
    For Each item In selectedItems
        sortedItems.Add item
    Next
    
    ' 根据视图的排序规则对集合排序
    For i = 1 To sortedItems.Count - 1
        For j = i + 1 To sortedItems.Count
            compareResult = 0
            ' 按视图的排序字段依次比较
            For Each sortField In sortFields
                If compareResult = 0 Then
                    ' 比较字段值，注意区分升序/降序
                    If sortField.SortOrder = olSortAscending Then
                        compareResult = StrComp(GetItemProperty(sortedItems(i), sortField.Field), _
                                               GetItemProperty(sortedItems(j), sortField.Field), vbTextCompare)
                    Else
                        compareResult = StrComp(GetItemProperty(sortedItems(j), sortField.Field), _
                                               GetItemProperty(sortedItems(i), sortField.Field), vbTextCompare)
                    End If
                End If
            Next sortField
            
            ' 如果后面的项应该排在前面，就交换位置
            If compareResult > 0 Then
                sortedItems.Add sortedItems(j), , i
                sortedItems.Remove j
            End If
        Next j
    Next i
    
    ' 返回排序后的第一个项（即显示最顶层的选中项）
    Set GetTopSelectedItem = sortedItems(1)
End Function

' 辅助函数：获取邮件项目的指定属性值
Function GetItemProperty(item As Object, field As String) As String
    On Error Resume Next
    GetItemProperty = item.PropertyAccessor.GetProperty(field)
    If Err.Number <> 0 Then GetItemProperty = ""
    On Error GoTo 0
End Function

方法二：借助Table对象获取排序后的选中项 #

另一种更简洁的方式是使用Folder.GetTable方法，利用当前视图的筛选和排序规则，直接获取符合条件的排序后项目，再匹配选中项：

Function GetTopSelectedItemViaTable() As Object
    Dim exp As Explorer
    Dim folder As Folder
    Dim tbl As Table
    Dim row As Row
    Dim selectedEntryIDs As Collection
    Dim itemID As String
    Dim topItemID As String
    
    Set exp = Application.ActiveExplorer
    Set folder = exp.CurrentFolder
    Set selectedEntryIDs = New Collection
    
    ' 收集所有选中项的EntryID
    For Each item In exp.Selection
        selectedEntryIDs.Add item.EntryID
    Next
    
    ' 获取当前视图的Table，自带排序规则
    Set tbl = folder.GetTable(exp.CurrentView.Filter, olTableAllColumns)
    
    ' 遍历Table，找到第一个在选中集合里的项
    Do Until tbl.EndOfTable
        Set row = tbl.GetNextRow
        itemID = row("EntryID")
        ' 检查是否在选中项里
        On Error Resume Next
        selectedEntryIDs.Item(itemID)
        If Err.Number = 0 Then
            topItemID = itemID
            Exit Do
        End If
        On Error GoTo 0
    Loop
    
    ' 通过EntryID获取对应的项目
    If topItemID <> "" Then
        Set GetTopSelectedItemViaTable = Application.Session.GetItemFromID(topItemID)
    End If
End Function

使用说明 #

• 当用户未勾选复选框时，直接调用上述任意一个函数，就能拿到列表显示最顶层的选中项目。
• 方法一适合需要保留选中项集合排序逻辑的场景，方法二更高效，尤其是选中项较多时。

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