Excel创建Outlook日历事件

您是否可以从Excel运行一个宏，该宏可以与Outlook交互，并在日历上创建约会和事件？

这将允许您将约会添加到任何文件夹中的共享日历中，只要您有权在其中写入

将日历视为文件夹

Const olFolderInbox = 6
Const olAppointmentItem = 1 '1 = Appointment

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
'Finds your Inbox
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)

'Gets the parent of your Inbox which gives the Users email
strFolderName = objInbox.Parent
Set objCalendar = objNamespace.Folders("Public folders - " & strFolderName).Folders("SubFolder1").Folders("subfolder of subfolder 1").Folders("Your Calendar")

Set objapt = objCalendar.Items.Add(olAppointmentItem)
objapt.Subject = "Test" 'Owner
objapt.Start = Date + TimeValue("08:00:00")
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
objapt.End= Date + TimeValue("16:00:00")
objapt.Save

---

其他答案稍有改进

Sub createappt()

Const olFolderCalendar = 9
Const olAppointmentItem = 1 '1 = Appointment

Set objOutlook = CreateObject("Outlook.Application")

'Set objOutlook = GetObject(, "Outlook.Application")  ' outlook already open
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set Items = objNamespace.GetDefaultFolder(olFolderCalendar).Items

Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("subfolder")
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender
Set objapt = objCalendar.Items.Add(olAppointmentItem)
objapt.Subject = "Test" 'Owner
objapt.Start = Date + TimeValue("08:00:00")
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
objapt.End = Date + TimeValue("16:00:00")
objapt.Save
End Sub

来自Tim通讯的链接-

---

下面是另一个链接

，看起来这会有很大帮助！非常感谢。你能补充这一点作为答案吗，这样我们其他乐于助人的灵魂就不会认为这是一个未回答的问题了另外，您如何添加到与您共享的另一个日历中？我不明白为什么这个问题因没有重点而关闭。它的标题准确地定义了所要求的内容，答案也很准确。

Sub AddAppointments2()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 2
    r = 2

    Do Until Trim(Cells(r, 1).Value) = ""
        For Each olapt In olFldr.Items
            If TypeName(myApt) = "AppointmentItem" Then
                If InStr(1, myApt.Subject, "Test and Tag", vbTextCompare) Then
                    myApt.Body = appt.Body & Cells(r, 2)
                    myApt.Save
                Else
                    ' Create the AppointmentItem
                    Set myApt = myOutlook.createitem(1)
                    ' Set the appointment properties
                    myApt.Subject = Cells(r, 1).Value
                    myApt.Location = Cells(r, 2).Value
                    myApt.Start = Cells(r, 4).Value + TimeValue("08:00:00")
                    myApt.Duration = Cells(r, 5).Value
                    ' If Busy Status is not specified, default to 2 (Busy)
                    If Trim(Cells(r, 6).Value) = "" Then
                        myApt.BusyStatus = 2
                    Else
                        myApt.BusyStatus = Cells(r, 6).Value
                    End If
                    If Cells(r, 7).Value > 0 Then
                        myApt.ReminderSet = True
                        myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value
                    Else
                        myApt.ReminderSet = False
                    End If
                    myApt.Body = Cells(r, 12).Value
                    myApt.Save
                    r = r + 1
                End If
            End If
        Next olapt
    Loop
End Sub