從 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。