Creating Outlook Appointment in Specific Folder-CodePudding

i'm trying to make Excel create Outlook appointments into a specific Calendar Folder (this is just so i can select which account i want the appointment to be created in) but i get an error: Rub=time error '5': Invalid procedure call or argument. this error happens when i try to put the detailed appointment into the folder. (the line with "Set OutlookAppt = objfolder.Items.Add(olAppointmentItem)")

please let me know if you have any ideas as to how to fix this.

thank you a bunch in advance!

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

CodePudding user response：

Can you adapt this code, which runs in 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

Setup:

CodePudding user response：

Replace the line

Set OutlookAppt = oApp.CreateItem(1)

with the following (creates the appointment in folder returned by PickFolder):

Set OutlookAppt = objfolder.Items.Add