从 Excel 将约会加载到非默认 Outlook 日历

Question

我有一个项目将员工休假时间表放入共享或全局日历中。

约会保存到我的默认日历。

我尝试了几种不同的方法。 这是当前的方法：

Sub Create_Outlook_2()
' Create the Outlook session

Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Dim myApt As AppointmentItem

Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000").Items.Add(olAppointmentItem)

With oFolder
'    Set myOutlook = CreateObject("Outlook.Application")
'    ' Set data collection to take from "Leave Table" sheet
    Dim wsSrc As Worksheet
    Set wsSrc = Sheets("Leave Table")
    ' Start looping at row 3 (first two rows are for readability)
    r = 3
    ' Do/while set condition
    Do Until Trim(wsSrc.Cells(r, 1).Value) = ""
        ' Create event item
        Set myApt = oApp.CreateItem(1)
        ' Set the event properties
        ' Set Subject line of event
        With myApt
            .Subject = "Time Off " & wsSrc.Cells(r, 1).Value & " " & wsSrc.Cells(r, 2).Value
           ' Set start time
            .Start = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 8).Value
           ' Set end time
            .End = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 9).Value
           ' Turn reminders off
            .ReminderSet = False
           ' Set busy status to free
            .BusyStatus = 0
           ' Have the body of the event read as the decription from the leave form in Viewpoint
            .Body = wsSrc.Cells(r, 4).Value
           ' Save event in owners calendar
            .Save

        End With
       ' Move to next row
        r = r + 1
       ' Repeat do/while loop until condition is no longer valid
    Loop

End With
End Sub

Answer 1

我想到了：

Sub Create_Outlook_2()

    Dim oApp As Object
    Dim oNameSpace As Namespace
    Dim oFolder As Object
    Dim wsSrc As Worksheet
    Set wsSrc = Sheets("Leave Table")
    ' Start looping at row 3 (first two rows are for readability)
    r = 3
    ' Do/while set condition
    Do Until Trim(wsSrc.Cells(r, 1).Value) = ""

        ' Create the Outlook session
        Set oApp = New Outlook.Application
        ' Set the namespace
        Set oNameSpace = oApp.GetNamespace("MAPI")
        ' Set the folder the appointment will be created in.
        Set oFolder = oNameSpace.GetFolderFromID("Folder ID Number").Items.Add(olAppointmentItem)

        ' Set with block for the appointment configuration loop
        With oFolder
           ' Set Subject line of event
            .Subject = wsSrc.Cells(r, 1).Value & " " & wsSrc.Cells(r, 2).Value
           ' Set start time
            .Start = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 8).Value
           ' Set end time
            .End = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 9).Value
           ' Turn reminders off
            .ReminderSet = False
           ' Set busy status to free
            .BusyStatus = 0
           ' Have the body of the event read as the decription from the leave form in Viewpoint
            .Body = wsSrc.Cells(r, 4).Value
           ' Save event in owners calendar
            .Save
           ' End with block
        End With
       ' Move to next row
        r = r + 1
       ' Repeat do/while loop until condition is no longer valid
    Loop

End Sub

要获取文件夹ID：

选中要创建约会的日历 （在新窗口中以良好的方式打开日历 ），按F11键调出Outlook宏，并在“ ThisOutlookSession”下运行以下代码：

Private Sub GetOutlookFolderID()
     'Determines the Folder ID of Folder
    Dim olfolder As Outlook.MAPIFolder
    Dim olapp As Outlook.Application
    Set olapp = CreateObject("Outlook.Application")
    Set olfolder = olapp.GetNamespace("MAPI").PickFolder
    olfolder.Display
    MsgBox (olfolder.EntryID)
    Set olfolder = Nothing
    Set olapp = Nothing
End Sub

电子表格样本-带有假名称：

Answer 2

还有另一种访问文件夹而不是获取ID的方法：

    Set oFolder = oNameSpace.Folders.Item("account address").Folders.Item("Calendar").Items.Add(olAppointmentItem)

其中“帐户地址”是帐户的电子邮件地址

此外，我正在使用多个Outlook.com日历，发现您可以执行以下操作来访问非默认日历之一：

Set oFolder = oNameSpace.Folders.Item("account address").Folders.Item("Calendar").Folders.Item("Other calendar name").Items.Add(olAppointmentItem)

约书亚（Joshua），如果没有您的发布，就不可能做到这一点。 谢谢！

Answer 3

我对这里提供的解决方案深表敬意和钦佩，你们是真正的巫师。 但是我必须想出一个方法来掌握 GetOutlookFolderID-Sub 提供的数字，这个数字很大。 解决方案被证明非常简单：

• 在您的 VBE 中打开 Direct window。
• 将“Private Sub GetOutlookFolderID()”中的行：MsgBox (olfolder.EntryID) 替换为以下行：Debug.Print olfolder.EntryID

并将 Direct window 中的数字复制到 Set olfolder-statement 中。

Answer 4

如果要使用Excel在Outlook中创建约会，请运行以下脚本。

Private Sub Add_Appointments_To_Outlook_Calendar()

    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oAppt As AppointmentItem
    Dim Remind_Time As Double

    i = 2
    Subj = ThisWorkbook.Sheets(1).Cells(i, 1)

    'Loop through entire list of Reminders to be added
    While Subj <> ""
        Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)

        oAppt.Subject = Subj
        oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
        oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
        Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
        oAppt.ReminderMinutesBeforeStart = Remind_Time
        oAppt.AllDayEvent = True
        oAppt.Save

        i = i + 1
        Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
    Wend
    MsgBox "Reminder(s) Added To Outlook Calendar"

End Sub

'该代码来自此链接： http : //officetricks.com/add-appointment-to-outlook-calendar-through-excel-macro-vba/

该脚本是从Excel运行的，因此，在运行代码之前必须设置对Outlook的引用。 另外，请注意，需要正确设置工作表才能运行脚本。 它看起来应该像这样。 一切都从Excel读入Outlook。