引用非默认日历以循环添加项目

Question

我遇到了这个宏，它将 MS Project 中的任务发送到 MS Outlook。

代码在我的默认日历中创建约会。

Sub Export_Selection_To_OL_Appointments()
Dim myTask As Task
Dim myItem As Object
    
On Error Resume Next
Set myOLApp = CreateObject("Outlook.Application")
  
For Each myTask In ActiveSelection.Tasks
    Set myItem = myOLApp.CreateItem(1)
    With myItem
        .Start = myTask.Start
        .End = myTask.Finish
        .Subject = " Rangebank PS " & myTask.Name
        .Categories = myTask.Project
        .Body = myTask.Notes
        .Save
    End With
Next myTask

End Sub

我想在不同的日历中创建约会。

我被提供了 this 作为引用非默认日历的方式。

Option Explicit

Sub NonDefaultFolder_Add_Not_Create()

Dim myOlApp As Object
Dim myDefaultStore As Object

Dim nonDefaultCalendar As Object
Dim myItem As Object

On Error Resume Next
Set myOlApp = CreateObject("Outlook.Application")

' Consider this mandatory.
' Limit the scope of the error bypass to the minimum number of lines.
' Ideally the scope is zero lines.
On Error GoTo 0

If Not myOlApp Is Nothing Then

    Set myDefaultStore = myOlApp.Session.defaultStore
    Debug.Print myDefaultStore
    
    ' This references a calendar on the same level as the default calendar
    Set nonDefaultCalendar = myOlApp.Session.Folders(myDefaultStore.DisplayName).Folders("Calendar Name")
    nonDefaultCalendar.Display
    
    ' Add to non-default folders (or create in the default then copy or move)
    Set myItem = nonDefaultCalendar.Items.Add
    With myItem
        .Subject = " Rangebank PS "
        .Display
    End With

Else
    MsgBox "Error creating Outlook object."
    
End If

End Sub

我试过这个。

Option Explicit

Sub NonDefaultFolder_Add_Not_Create()
Dim myTask As Task
Dim myItem As Object
Dim myOLApp As Object
Dim myDefaultStore As Object
Dim nonDefaultCalendar As Object
On Error Resume Next
Set myOLApp = CreateObject("Outlook.Application")
  
For Each myTask In ActiveSelection.Tasks
    Set myItem = myOLApp.CreateItem(1)
    With myItem
        .Start = myTask.Start
        .End = myTask.Finish
        .Subject = " Rangebank PS " & myTask.Name
        .Categories = myTask.Project
        .Body = myTask.Notes
        .Save

On Error GoTo 0

If Not myOLApp Is Nothing Then

    Set myDefaultStore = myOLApp.Session.DefaultStore
    Debug.Print myDefaultStore
    
    Set nonDefaultCalendar = myOLApp.Session.Folders(myDefaultStore.DisplayName).Folders("B2A Projects Calendar")
    nonDefaultCalendar.Display
    
    ' Add to non-default folders (or create in the default then copy or move)
    Set myItem = nonDefaultCalendar.Items.Add
    With myItem
        .Subject = " Rangebank PS "
        .Display
    End With
    End If

End With
End Sub

我得到：

“编译错误：对于没有下一个”

它突出显示

End Sub

。

在

Next

之前添加

End Sub

修复了该问题，但找不到自定义日历：

“运行时错误‘-2147221233 (8004010f)’：尝试的操作失败。找不到对象。

然后突出显示

Set nonDefaultCalendar = myOLApp.Session.Folders(myDefaultStore.DisplayName).Folders("B2A Projects Calendar")

日历的名称是正确的，因此不是拼写错误。

Answer 1

您可能会发现 NameSpace.GetSharedDefaultFolder 方法很有用，它用于委派场景，其中一个用户将其一个或多个默认文件夹（例如，他们的共享日历文件夹）的访问权限委派给另一用户。

您还可以获取默认日历文件夹（或父文件夹）并尝试迭代所有子文件夹以找到所需的文件夹。例如：

OutlookApp.Session.Folders(yourDefaultStore.DisplayName).Folders("Calendar Name")

属性和方法调用的顺序取决于实际文件夹位置。