调整从 MS Project 创建 Outlook 事件的 VBA 代码

Question

需要一些帮助来调整此代码，该代码将 MS Project 任务作为事件发送到 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

谢谢

尝试添加我在网上找到的代码，但没有成功

Answer 1

这演示了如何引用非默认 Outlook 文件夹来添加项目。

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