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宏并在＆＃34; ThisOutlookSession＆下运行以下代码＃34;：

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

There's an additional way to access the folder instead of getting the ID:

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

Where "account address" is the email address of the account

Additionally, I'm working with multiple outlook.com calendars and found that you can do the following to access one of the non-default calendars:

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

Couldn't have done any of this without your post, Joshua. Thanks!

Answer 3

如果要使用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

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

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

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

3 个答案: