从 Excel 向 Outlook 2010 添加约会

Question

I am trying to use the code below to update my Outlook calendar from an Excel sheet.
The code functions fine, but I need to save to a sub calendar rather than my default one.
I've tried a few work around's I found online,but none of them seem to work. For example Slapstick and also at the bottom of this page Ozgrid
Any help would be much appreciated.

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

To get access to a subfolder in your default calendar folder you can use:

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

If it is on the same level as teh default folder you can use:

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

Good resource here and here .

Answer 2

As described in the Ozgrid link, move the appointment created in the default calendar to the sub calendar.

You can reference a calendar with the entry ID.

Set oFolder = oNameSpace.GetFolderFromID("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")   

You can reference a sub Calendar of the default folder:

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

Once created in the default calendar move it to the non-default calendar

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

Answer 3

You may add to a non-default calendar.

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

With olAppt
     '...
     .Save
End With