从Excel向Outlook 2010添加约会：如何保存到子日历

我明白你遇到的问题——代码能正常创建约会，但一直存到默认日历里，之前找的方法没生效对吧？核心原因是你当前的代码默认绑定了Outlook的主日历，我们需要调整代码来直接定位并使用子日历文件夹，而不是事后移动约会（这种方式容易出问题）。

关键修改思路 #

1. 正确定位子日历：子日历是默认日历文件夹的子文件夹，所以要先获取默认日历，再通过Folders集合找到你的子日历（替换成你实际的子日历名称）。
2. 直接在子日历创建约会：不要用OL.CreateItem(olAppointmentItem)，而是用子日历文件夹的Items.Add方法，这样约会会直接保存在目标子日历中。
3. 修复拼写错误：原代码里的Catagory是拼写错误，正确的属性名是Category，这个小错误也可能导致部分功能异常。

修改后的完整代码 #

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, dCategory As Double ' 修复拼写：Catagory → Category
 Dim sSearch As String, bOLOpen As Boolean
 Dim subCalendar As Outlook.Folder ' 新增：用于存储子日历文件夹

 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")

 ' --------------------------
 ' 修改：获取子日历文件夹（替换"My Sub Calendar"为你的子日历名称）
 ' --------------------------
 Set subCalendar = NS.GetDefaultFolder(olFolderCalendar).Folders("My Sub Calendar")
 If subCalendar Is Nothing Then
 MsgBox "未找到指定的子日历，请检查名称是否正确！", vbExclamation
 Exit Sub
 End If

 Set colItems = subCalendar.Items ' 从子日历获取Items集合
 colItems.Sort "[Start]", olAscending ' 可选：排序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 = subCalendar.Items.Add(olAppointmentItem)
 olAppt.Body = sBody
 olAppt.Subject = sSubject
 olAppt.Start = dStartTime
 olAppt.End = dEndTime
 olAppt.Location = sLocation
 olAppt.Category = dCategory ' 修复拼写：Catagory → Category
 ' 可选：设置提醒时间（如果dReminder是分钟数的话）
 If IsNumeric(dReminder) Then
 olAppt.ReminderMinutesBeforeStart = CLng(dReminder)
 olAppt.ReminderSet = True
 End If
 olAppt.Close olSave
 End If
NextRow:
 Next r

 If bOLOpen = False Then OL.Quit
 ' 释放对象
 Set olAppt = Nothing
 Set colItems = Nothing
 Set subCalendar = Nothing
 Set NS = Nothing
 Set OL = Nothing
End Sub

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

注意事项 #

• 请把代码中的"My Sub Calendar"替换成你Outlook中实际的子日历名称，名称要完全匹配（包括大小写和空格）。
• 如果你的子日历不是直接在默认日历下（比如嵌套在其他文件夹里），需要调整路径，比如NS.Folders("邮箱账户名称").Folders("日历").Folders("子日历名称")。
• 运行代码前确保Outlook已经授权Excel访问（第一次运行会弹出权限提示，选择允许即可）。

内容的提问来源于stack exchange，提问作者elbruzo