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

资源良好here和here。

Answer 2

如Ozgrid链接所述，将默认日历中创建的约会移至子日历。

您可以使用条目ID引用日历。

new RegExp("mediaType")

您可以引用默认文件夹的子日历：

Set oFolder = oNameSpace.GetFolderFromID("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")

在默认日历中创建后，将其移至非默认日历

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

Answer 3

您可以添加到非默认日历。

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

With olAppt
     '...
     .Save
End With

使用VBA从Excel添加到Outlook 2010的约会

3 个答案: