如何通过VBA根据办公室（会议室）名称获取Outlook全局地址列表显示名称？

核心思路 #

Outlook全局地址列表(GAL)本质是Exchange/AD的地址集合，我们可以通过VBA操作Outlook对象模型，筛选Office字段与Excel中会议室名称匹配的条目，提取其显示名称。以下提供两种实现方式，分别适配不同场景。

方法1：遍历GAL条目（适合小规模会议室列表） #

直接遍历GAL中的Exchange用户/会议室资源条目，匹配Office字段：

Sub GetRoomDisplayNameFromGAL()
    Dim olApp As Object
    Dim olNS As Object
    Dim gal As Object
    Dim entry As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim roomName As String
    
    ' 指定目标工作表（可根据实际修改）
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 初始化Outlook对象（后期绑定，无需手动添加引用）
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    
    ' 自动定位GAL（兼容不同语言/环境下的GAL名称）
    For Each gal In olNS.AddressLists
        If gal.AddressListType = 0 Then ' olExchangeGlobalAddressList
            Exit For
        End If
    Next gal
    
    ' 遍历Excel中的会议室名称
    For i = 2 To lastRow ' 假设A列第1行是表头
        roomName = Trim(ws.Cells(i, "A").Value)
        If roomName <> "" Then
            ' 遍历GAL条目查找匹配项
            For Each entry In gal.AddressEntries
                ' 仅处理Exchange用户或会议室资源类型条目
                If entry.AddressEntryUserType = 0 Or entry.AddressEntryUserType = 10 Then
                    On Error Resume Next ' 跳过无ExchangeUser属性的无效条目
                    If Trim(entry.GetExchangeUser.Office) = roomName Then
                        ws.Cells(i, "B").Value = entry.Name
                        Exit For ' 找到匹配项立即跳出循环
                    End If
                    On Error GoTo 0
                End If
            Next entry
        End If
    Next i
    
    ' 释放对象
    Set entry = Nothing
    Set gal = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    MsgBox "查询完成！", vbInformation
End Sub

方法2：Outlook高级搜索（适合大规模列表，效率更高） #

利用Outlook的AdvancedSearch功能直接搜索GAL的Office字段，避免逐条遍历：

Sub AdvancedSearchRoomDisplayName()
    Dim olApp As Object
    Dim olNS As Object
    Dim searchObj As Object
    Dim searchResults As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim roomName As String
    Dim searchFilter As String
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    
    ' 遍历Excel中的会议室名称
    For i = 2 To lastRow
        roomName = Trim(ws.Cells(i, "A").Value)
        If roomName <> "" Then
            ' 构建SQL搜索过滤器，匹配Office字段（转义单引号避免语法错误）
            searchFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:office" & Chr(34) & " = '" & Replace(roomName, "'", "''") & "'"
            
            ' 执行GAL搜索
            Set searchObj = olNS.AdvancedSearch("Global Address List", searchFilter, False)
            
            ' 等待搜索完成
            Do While searchObj.SearchComplete = False
                DoEvents
            Loop
            
            Set searchResults = searchObj.Results
            ' 将第一个匹配结果的显示名称写入B列
            If searchResults.Count > 0 Then
                ws.Cells(i, "B").Value = searchResults(1).Name
            End If
        End If
    Next i
    
    ' 释放对象
    Set searchResults = Nothing
    Set searchObj = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    MsgBox "高级查询完成！", vbInformation
End Sub

注意事项 #

1. 匹配精度：确保Excel中的会议室名称与GAL里的Office字段完全一致（包括空格、大小写，代码已做Trim处理）。
2. Outlook权限：运行代码前需确保Outlook已登录，且有权限访问GAL。
3. GAL定位：方法1中自动识别GAL类型，避免因语言环境导致的GAL名称差异（比如部分环境下GAL名称为中文“全局地址列表”）。

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