從 Excel 向 Outlook 2010 添加約會

Question

我正在嘗試使用下面的代碼從 Excel 工作表更新我的 Outlook 日歷。
代碼運行良好，但我需要保存到子日歷而不是我的默認日歷。
我已經嘗試了一些我在網上找到的解決方法，但它們似乎都不起作用。 例如Slapstick以及本頁底部的Ozgrid
任何幫助將不勝感激。

Option Explicit
Sub AddToOutlook()


Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sBody As String, sSubject As String, sLocation As String
Dim dStartTime As Date, dEndTime As Date, dReminder As String, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean

On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
    Set OL = CreateObject("Outlook.Application")
    bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items


For r = 2 To 394

    If Len(Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value) = 0 Then 
    GoTo NextRow
    sBody = Sheet1.Cells(r, 7).Value
    sSubject = Sheet1.Cells(r, 3).Value
    dStartTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 2).Value
    dEndTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value
    sLocation = Sheet1.Cells(r, 6).Value
    dReminder = Sheet1.Cells(r, 4).Value

    sSearch = "[Subject] = " & sQuote(sSubject)
    Set olApptSearch = colItems.Find(sSearch)


    If olApptSearch Is Nothing Then
        Set olAppt = OL.CreateItem(olAppointmentItem)
        olAppt.Body = sBody
        olAppt.Subject = sSubject
        olAppt.Start = dStartTime
        olAppt.End = dEndTime
        olAppt.Location = sLocation
        olAppt.Catagory = dCatagory
        olAppt.Close olSave
    End If


NextRow:
Next r


If bOLOpen = False Then OL.Quit


End Sub


Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function

Answer 1

要訪問默認日歷文件夾中的子文件夾，您可以使用：

Set colItems = NS.GetDefaultFolder(olFolderCalendar).Folders("TypeNameOfCalendarHere").Items

如果它與默認文件夾在同一級別，您可以使用：

Set colItems = NS.GetDefaultFolder(olFolderCalendar).Parent.Folders("SharedCal").Items

這里和這里的好資源。

Answer 2

如Ozgrid鏈接中所述，將在默認日歷中創建的約會移至子日歷。

您可以使用條目 ID 引用日歷。

Set oFolder = oNameSpace.GetFolderFromID("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")   

您可以引用默認文件夾的子日歷：

Set oFolder = NS.GetDefaultFolder(olFolderCalendar).folders("Name of sub calendar")

在默認日歷中創建后將其移動到非默認日歷

Set olApt = oApp.CreateItem(olAppointmentItem)
With olApt
    ' ..
    .Save
    .Move oFolder
End With

Answer 3

您可以添加到非默認日歷。

Set subCalendar = NS.GetDefaultFolder(olFolderCalendar).folders("Name of sub calendar")
Set olAppt = subCalendar.items.Add

With olAppt
     '...
     .Save
End With