我试图使用下面的代码从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
如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
您可以添加到非默认日历。
Set subCalendar = NS.GetDefaultFolder(olFolderCalendar).folders("Name of sub calendar")
Set olAppt = subCalendar.items.Add
With olAppt
'...
.Save
End With