VBA遍历Outlook共享日历报错：权限与属性异常问询

1. 异常资源的DefaultItemType为olMailItem的原因 #

主要是两种情况导致：

• 资源账户的默认日历文件夹配置异常：Exchange服务器上的资源邮箱可能被修改过默认文件夹映射，导致GetSharedDefaultFolder返回的不是真正的日历文件夹，而是误识别为邮件类型的文件夹；
• 共享的不是系统默认日历：客户端显示的日历是资源账户下的自定义日历文件夹，而非系统默认日历，API调用olFolderCalendar参数时无法正确匹配目标文件夹，返回了默认的邮件类型文件夹。

2. Items属性访问失败的原因 #

• 类型不匹配：当DefaultItemType为olMailItem时，Items集合默认存储邮件项，而实际文件夹中是日历预约项，直接访问会触发类型转换错误；
• API权限限制：客户端能查看日历不代表宏拥有API层面的文件夹访问权限，部分Exchange环境下，需要给资源账户配置显式的文件夹可见性+读取权限，而非仅客户端的查看权限；
• 缓存同步问题：Outlook客户端缓存了日历内容，但宏访问的是MAPI命名空间的实时服务器数据，两者未同步导致API无法正确加载文件夹内容。

3. 稳定访问所有共享日历的替代方案 #

方案1：遍历资源账户子文件夹定位日历 #

跳过GetSharedDefaultFolder，直接获取资源账户根文件夹，遍历子文件夹找到日历类型的目标文件夹，同时优化预约筛选逻辑减少循环次数：

Public Function getDailyHours(thisDay As Date) As Single

    Const minperhr As Integer = 60
    Dim olApp As Application
    Dim olNS As NameSpace
    Dim thisAppt As Outlook.AppointmentItem
    Dim ResourceNames As Variant
    Dim thisResourceName As String
    Dim thisResourceAccount As Outlook.Recipient
    Dim thisResourceRoot As Outlook.Folder
    Dim targetCalendar As Outlook.Folder
    Dim myAccount As Outlook.Recipient
    Dim tempHrs As Single
    Dim i As Long
    Dim j As Long
    Dim subFolder As Outlook.Folder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set myAccount = olNS.Session.CurrentUser

    ResourceNames = Array("resource1@mycompany.com", "resource2@mycompany.com", "resource3@mycompany.com", "resource4@mycompany.com")
    tempHrs = 0
    
    For i = LBound(ResourceNames) To UBound(ResourceNames)
        thisResourceName = ResourceNames(i)
        Set thisResourceAccount = olNS.CreateRecipient(thisResourceName)
        
        If thisResourceAccount.Resolve Then
            ' 通过收件箱获取资源账户的根文件夹
            Set thisResourceRoot = olNS.GetSharedDefaultFolder(thisResourceAccount, olFolderInbox).Parent
            ' 遍历根文件夹下的子文件夹，找到日历类型文件夹
            For Each subFolder In thisResourceRoot.Folders
                If subFolder.DefaultItemType = olAppointmentItem Then
                    Set targetCalendar = subFolder
                    Exit For
                End If
            Next subFolder
        Else
            Set targetCalendar = Nothing
        End If
        
        If Not (targetCalendar Is Nothing) Then
            ' 先筛选当日预约，减少循环量
            targetCalendar.Items.Sort "[Start]"
            targetCalendar.Items.IncludeRecurrences = True
            Dim filterStr As String
            filterStr = "[Start] >= '" & Format(thisDay, "ddddd hh:mm AMPM") & "' AND [End] < '" & Format(thisDay + 1, "ddddd hh:mm AMPM") & "'"
            Dim filteredItems As Outlook.Items
            Set filteredItems = targetCalendar.Items.Restrict(filterStr)
            
            For j = 1 To filteredItems.Count
                Set thisAppt = filteredItems(j)
                If thisAppt.Organizer = myAccount.Name Then
                    tempHrs = tempHrs + CSng(thisAppt.Duration) / CSng(minperhr)
                End If
            Next j
        End If

        Set thisResourceAccount = Nothing
        Set thisResourceRoot = Nothing
        Set targetCalendar = Nothing
    Next i

    getDailyHours = tempHrs
End Function

方案2：修复资源账户默认配置 #

联系Exchange管理员，检查resource3/4账户的默认文件夹设置，确保默认日历文件夹的DefaultItemType为olAppointmentItem，并确认共享的是系统默认日历而非自定义文件夹。

方案3：使用Exchange Web Services（EWS） #

如果VBA的MAPI方式受限，可以通过EWS API直接调用Exchange服务器获取资源日历数据，权限配置更灵活，且不受客户端缓存影响。

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