访问自定义 Outlook 日历条目

Question

我正在尝试使用 Excel VBA 从 2 个自定义 Outlook 日历访问日历条目。

我已经获得了一些代码，可以从默认日历中获得我想要的内容，但我看不到如何将位置更改为我自己的日历。

我使用的代码是

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim nextrow As Long
    Dim FromDate As Date
    Dim ToDate As Date
    
    FromDate = CDate("30/11/2021")
    ToDate = CDate("20/12/2021")
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9)
    nextrow = 2
    
    With Sheets("Cal-Ext")
        .Range("A1:E1").Value = Array("Date", "Start Time", "End Time", "Subject", "Location")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(nextrow, "A").Value = CDate(olApt.Start)
                .Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
                .Cells(nextrow, "B").Value = olApt.Start
                .Cells(nextrow, "B").NumberFormat = "HH:MM"
                .Cells(nextrow, "C").Value = olApt.End
                .Cells(nextrow, "C").NumberFormat = "HH:MM"
                .Cells(nextrow, "D").Value = olApt.Subject
                .Cells(nextrow, "E").Value = olApt.Location
                nextrow = nextrow + 1
            Else
            End If
        Next olApt
    
    
        Set olFolder = olNS.GetDefaultFolder(9)
    
        nextrow = nextrow + 5
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(nextrow, "A").Value = CDate(olApt.Start)
                .Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
                .Cells(nextrow, "B").Value = olApt.Start
                .Cells(nextrow, "B").NumberFormat = "HH:MM"
                .Cells(nextrow, "C").Value = olApt.End
                .Cells(nextrow, "C").NumberFormat = "HH:MM"
                .Cells(nextrow, "D").Value = olApt.Subject
                .Cells(nextrow, "E").Value = olApt.Location
                nextrow = nextrow + 1
            Else
            End If
        Next olApt
    
        .Columns.AutoFit
    End With
    
    
    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

我需要在第二个循环之前更改 set olfolder 命令以选择我自己的日历，但我尝试过的没有任何效果。

Outlook 日历

当前的excel结果

Answer 1

这是我编写的快速代码，用于遍历我的日历

的所有导航文件夹

此代码已在 MS Outlook 中测试。您可能需要对其进行编辑才能使其在 MS Excel 中工作。

Option Explicit

Sub Sample()
    Dim oNameSpace As Object
    Dim oExplorer As Object
    Dim oMainFolder As Object
    Dim oCalModule As Object
    Dim oSubFolder As Object
    Dim oCalNavFolders As Object
    Dim i As Long
    Dim objitem As Object
    
    Set oNameSpace = Outlook.GetNamespace("MAPI")
    Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
    Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
    Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
    
    For i = 1 To oCalNavFolders.Count
        Set objitem = oCalNavFolders(i)
        
        On Error Resume Next
        Set oSubFolder = objitem.Folder
        On Error GoTo 0
                
        If Not oSubFolder Is Nothing Then
            Debug.Print oSubFolder.Name
            If oSubFolder.Name = "Area1" Then
                With oSubFolder
                    '
                    '~~> Do what you want
                    '
                End With
                Exit For
            End If
            
            Set oSubFolder = Nothing
        End If
    Next i
End Sub

截图

Excel 中的代码

Option Explicit

Sub ListAppointments()
    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")

    Dim oNameSpace As Object
    Dim oExplorer As Object
    Dim oMainFolder As Object
    Dim oCalModule As Object
    Dim oSubFolder As Object
    Dim oCalNavFolders As Object
    Dim i As Long
    Dim objitem As Object
    
    Set oNameSpace = OutApp.GetNamespace("MAPI")
    Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
    Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
    Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
    
    For i = 1 To oCalNavFolders.Count
        Set objitem = oCalNavFolders(i)
        
        On Error Resume Next
        Set oSubFolder = objitem.Folder
        On Error GoTo 0
                
        If Not oSubFolder Is Nothing Then
            Debug.Print oSubFolder.Name
            If oSubFolder.Name = "Area1" Then
                With oSubFolder
                    '
                    '~~> Do what you want
                    '
                End With
                Exit For
            End If
            
            Set oSubFolder = Nothing
        End If
    Next i
End Sub