在特定文件夹中创建 Outlook 约会

Question

我正在尝试让 Excel 将 Outlook 约会创建到特定的日历文件夹中（这只是为了让我可以选择要在哪个帐户中创建约会）但我收到一个错误：Rub=time error '5': Invalid procedure调用或争论。 当我尝试将详细约会放入文件夹时会发生此错误。 （带有“设置 OutlookAppt = objfolder.Items.Add(olAppointmentItem)”的行）

如果您对如何解决此问题有任何想法，请告诉我。

提前谢谢你！

Sub AddAppointments()

    Dim LastRow As Long
    Dim I As Long
    Dim xRg As Range
    Dim myNamespace As Object
    Dim myRecipient As Object
    Dim objfolder As Object
    Dim OutlookAppt As Object 

    Set OutApp = GetObject(, "Outlook.Application")
        If ErrL <> 0 Then
            Set oApp = CreateObject("Outlook.Application")
        End If
 
    Set myNamespace = OutApp.GetNamespace("MAPI")
    Set objfolder = myNamespace.PickFolder 'lets user pick folder where appt will be created
 
    Set xRg = Range("A2:G2")
        LastRow = Range("A" & Rows.Count).End(xlUp).Row
        For I = 1 To (LastRow - 1)
            If LCase(Trim(xRg.Cells(I, 8).Value)) <> "yes" Then
                Set OutlookAppt = oApp.CreateItem(1)
                OutlookAppt.Subject = xRg.Cells(I, 1).Value
                OutlookAppt.Location = xRg.Cells(I, 2).Value
                OutlookAppt.Start = xRg.Cells(I, 3).Value
                OutlookAppt.Duration = xRg.Cells(I, 4).Value
                xRg.Cells(I, 8).Value = "Yes"
                If Trim(xRg.Cells(I, 5).Value) = "" Then
                    OutlookAppt.BusyStatus = 2
                Else
                    OutlookAppt.BusyStatus = xRg.Cells(I, 5).Value
                End If
                If xRg.Cells(I, 6).Value > 0 Then
                    OutlookAppt.ReminderSet = True
                    OutlookAppt.ReminderMinutesBeforeStart = xRg.Cells(I, 6).Value
                Else
                    OutlookAppt.ReminderSet = False
                End If
                OutlookAppt.Body = xRg.Cells(I, 7).Value
            End If

            **Set OutlookAppt = objfolder.Items.Add(olAppointmentItem)**

        Next       
    Set OutlookAppt = Nothing
End Sub

Answer 1

你能修改这个在 Excel 中运行的代码吗？

Sub MultiCalendars()
    Dim objPane As Outlook.NavigationPane
    Dim objModule As Outlook.CalendarModule
    Dim objGroup As Outlook.NavigationGroup
    Dim objNavFolder As Outlook.NavigationFolder
    Dim objFolder As Folder
    Dim calItem As Object
    Dim mtgAttendee As Outlook.Recipient
   
    Dim i As Integer
    
    Set Application.ActiveExplorer.CurrentFolder = Session.GetDefaultFolder(olFolderCalendar)
    DoEvents
    
    Set objPane = Application.ActiveExplorer.NavigationPane
    Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
    
    With objModule.NavigationGroups
        Set objGroup = .GetDefaultNavigationGroup(olMyFoldersGroup)
 
    ' To use a different calendar group
'        Set objGroup = .Item("Shared Calendars")
    End With
 
 
    For i = 1 To objGroup.NavigationFolders.Count
        If (objGroup.NavigationFolders.Item(i).Folder.FullFolderPath = "\\Mailbox - Doe, John T\Calendar") Then
            Set objNavFolder = objGroup.NavigationFolders.Item(i)
            Set calItem = objNavFolder.Folder.Items.Add(olAppointmentItem)
            calItem.MeetingStatus = olMeeting
            calItem.Subject = "Test Meeting - Ignore"
            calItem.Location = "TBD Location"
            calItem.Start = #1/19/2015 1:30:00 PM#
            calItem.Duration = 90
            Set mtgAttendee = calItem.Recipients.Add("John Doe")
            mtgAttendee.Type = olRequired
            Set mtgAttendee = calItem.Recipients.Add("Jane Doe")
            mtgAttendee.Type = olOptional
            Set mtgAttendee = calItem.Recipients.Add("CR 101")
            mtgAttendee.Type = olResource
            calItem.Save
            If (calItem.Recipients.ResolveAll) Then
                calItem.Send
            Else
                calItem.Display
            End If
        End If
    Next
 
    Set objPane = Nothing
    Set objModule = Nothing
    Set objGroup = Nothing
    Set objNavFolder = Nothing
    Set objFolder = Nothing
    Set calItem = Nothing
    Set mtgAttendee = Nothing
End Sub

设置：

Answer 2

换行

Set OutlookAppt = oApp.CreateItem(1)

使用以下内容（在 PickFolder 返回的文件夹中创建约会）：

Set OutlookAppt = objfolder.Items.Add