访问自定义 Outlook 日历条目

Posted 2023-03-27

【中文标题】访问自定义 Outlook 日历条目

【英文标题】：Accessing Custom Outlook Calendar Entries

【发布时间】：2022-01-13 06:48:49

【问题描述】：

我正在尝试使用 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结果

【参考方案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

【讨论】：

不能让它在 excel 中工作 - 将继续尝试，但不确定我还需要做什么

发布了我从 Excel 中尝试过的代码，它工作得很好......

此代码为我运行，直到我尝试添加我的位然后我得到运行时 438 错误对象不支持此属性或方法。这可能是我没有做过的愚蠢的事情，但是在 oSubFolder.items .Cells(nextrow, "A").Value = CDate(olApt.Start) .Cells(nextrow, "A").NumberFormat = "DD /MM/YYYY" .Cells(nextrow, "B").Value = olApt.Start 给了我错误。

你遇到了什么错误？

"运行时 438 错误对象不支持此属性或方法" 它出现在我从项目中选择数据的第一个命令中 .Cells(nextrow, "A").Value = CDate(olApt.Start)