Add outlook entry to non default calendar

[Ade F]

Firstly thanks to all the hard working people on here helping others. This forum has been the source for problem solving quite a few times.

This is driving me up the wall now and it's probably wood form the trees but here goes.

I have a folder under the default on in outlook named ANOTHER FOLDER. All I am trying to do is add the blasted entry to this folder. At the moment though it is adding the information to the default calendar and not ANOTHER FOLDER. I'm just testing at the moment but I have tried all manner of combination but no dice.

'Error 429 occurs with GetObject if Outlook is not running.
   
   On Error Resume Next
   Set objOutlook = GetObject(, "Outlook.Application")

   If Err.Number = 429 Then 'Outlook is NOT running.
      
    MsgBox "Outlook is not running please start and wait for it to completely load then press this button again.", vbCritical, "Whoops Outlook isn't running"
   
   Else
    
    MsgBox "You have just updated the outlook calendar. ", vbInformation, Title:="Outlook Calendar Updated"

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim olAppt As Outlook.AppointmentItem
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder("ANOTHER CALENDAR")

    Set olAppt = olApp.CreateItem(olAppointmentItem)
    
    olAppt.Start = Me.DateOfJob
    olAppt.subject = Me.Job_ID
    olAppt.Location = "Test"
    olAppt.Body = "Test"
    olAppt.ReminderSet = True
    
    'Set reminder for 1 day before.
    olAppt.ReminderMinutesBeforeStart = 1440
    olAppt.AllDayEvent = True
    olAppt.Save

    Set olAppt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing

   End If

Can anyone please shed any light on what I am doing wrong here.:banghead:

 

[Fran Lombard]

I think you are using the wrong object and method to get the desired folder.
The getdefualtfolder method does just that gets the default folder of a particular folder type. To get a non-default folder I think you need to use the folders object

 

[Ade F]

Thanks Fran. I have tried all manner of combinations I wondered if anyone could give a code example. This is driving me crackers.

 

[Fran Lombard]

I could not create the appointment in a sub Calender but was able to move it to the desired calender.

Check out the updated version of your code -

This should accomplish what you need

'Error 429 occurs with GetObject if Outlook is not running.
   
   On Error Resume Next
   Set objOutlook = GetObject(, "Outlook.Application")

   If Err.Number = 429 Then 'Outlook is NOT running.
      
    MsgBox "Outlook is not running please start and wait for it to completely load then press this button again.", vbCritical, "Whoops Outlook isn't running"
   
   Else
    
    MsgBox "You have just updated the outlook calendar. ", vbInformation, Title:="Outlook Calendar Updated"

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olDefualtFolder As Outlook.Folder
    Dim olDestinationFolder As Outlook.Folder
    Dim olFolders As Outlook.Folders
    Dim olAppt As Outlook.AppointmentItem
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")

' Set the Defualt Folder to the appropriate folder type
    Set olDefualtFolder = olNS.GetDefaultFolder(olFolderCalendar)

'get the defualt calenders collection of sub folders
    Set olFolders = olDefualtFolder.Folders

'get the specific destination folder
    Set olDestinationFolder = olFolders.Item("ANOTHER CALENDAR")

    Set olAppt = olApp.CreateItem(olAppointmentItem)

    
    olAppt.Start = Me.DateOfJob
    olAppt.Subject = Me.Job_ID
    olAppt.Location = "Test"
    olAppt.Body = "Test"
    olAppt.ReminderSet = True
    
    'Set reminder for 1 day before.
    olAppt.ReminderMinutesBeforeStart = 1440
    olAppt.AllDayEvent = True
    olAppt.Save


' move item to desired destination folder
    olAppt.Move olDestinationFolder
    
    Set olAppt = Nothing
    Set olDefualtFolder= Nothing
    Set olFolders = Nothing
    Set olDestinationFolder = Nothing
    
    Set olNS = Nothing
    Set olApp = Nothing

   End If

 

[Fran Lombard]

update

If you remove the olAppt.Save then outlook creates the appointment and saves it in the desired folder on the olAppt.Move call.

Hope this helps - Fran

 

[Ade F]

Thanks for you time Fran it works.

I can use it but It pains me to ask but why cant an entry just be created directly in the specified Calendar.

It would be perfect to putting it directly into the correct place.

 

[Ade F]

Ok this goes out to Fran or someone else who can shed some light on this.

I really need the calendar entry to be placed directly into the sub folder. The reason being this is being added to a google apps outlook calendar and they do not allow moving from the default calendar to the sub folder. The entry needs to be made directly into the sub folder.

Any additional help from people would be appreciated thanks. This folder issue has me stumped:banghead:

 

[Fran Lombard]

Did you try removing the call to save as mentioned in my update post?
I am not familiar with google apps outlook so I can't comment on why the move is not allowed.
Im at work now building a deck - I will try somethings tonight if you can't get it working.
Please update your status by end of day.
Good luck

 

[Fran Lombard]

Here's an update to the code that works as you want.
As it turns out - you need to add an Item to the Items collection of the
destination folder.

'Error 429 occurs with GetObject if Outlook is not running.
   
   On Error Resume Next
   Set objOutlook = GetObject(, "Outlook.Application")

   If Err.Number = 429 Then 'Outlook is NOT running.
      
    MsgBox "Outlook is not running please start and wait for it to completely load then press this button again.", vbCritical, "Whoops Outlook isn't running"
       Exit Sub
   End If
    
On Error GoTo SubError

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olDefualtFolder As Outlook.Folder
    Dim olDestinationFolder As Outlook.Folder
    Dim olFolders As Outlook.Folders
    Dim olItems As Outlook.Items
    Dim olAppt As Outlook.AppointmentItem
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")

' Set the Defualt Folder to the appropriate folder type
    Set olDefualtFolder = olNS.GetDefaultFolder(olFolderCalendar)

'get the defualt calenders collection of sub folders
    Set olFolders = olDefualtFolder.Folders

'get the specific destination folder
    Set olDestinationFolder = olFolders.Item("ANOTHER CALENDAR")

'get the collection of items in destination folder
     Set olItems = olDestinationFolder.Items

' Add an item to the collection
    Set olAppt = olItems.Add(olAppointmentItem)

'Set properties of item
    olAppt.Start = Me.DateOfJob
    olAppt.Subject = Me.Job_ID
    olAppt.Location = "Test"
    olAppt.Body = "Test"
    olAppt.ReminderSet = True
    
    'Set reminder for 1 day before.
    olAppt.ReminderMinutesBeforeStart = 1440
    olAppt.AllDayEvent = True
    olAppt.Save

    MsgBox "You have just updated the outlook calendar. ", vbInformation, Title:="Outlook Calendar Updated"

' move item to desired destination folder - no longer needed
'    olAppt.Move olDestinationFolder

  SubExit:  
    Set olAppt = Nothing
    Set olDefualtFolder= Nothing
    Set olFolders = Nothing
    Set olDestinationFolder = Nothing
    
    Set olNS = Nothing
    Set olApp = Nothing

   Exit Sub

SubError:
    MsgBox "Error Number: " & Err.Number & " - " & Err.Description
    Resume SubExit

Good Luck - Hope this helps
Fran

 

[Ade F]

Thanks Fran.

This is my last effort that worked. Here is the stripped down and streamlined code for anyone else.

Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim olFldr As Outlook.MAPIFolder
    
Set olApp = New Outlook.Application
Set olFldr = olApp.GetNamespace("MAPI").GetDefaultFolder(9).Folders("ANOTHER FOLDER")
Set olAppt = olFldr.Items.Add

With olAppt

    olAppt.Start = Date
    olAppt.Duration = 90
    olAppt.subject = "Subject Text"
    olAppt.Location = "London"
    
    olAppt.Body = "Body Text"
    olAppt.ReminderSet = False
    olAppt.AllDayEvent = True
    
    .Save
    
End With

    Set olApp = Nothing
    Set olAppt = Nothing
    Set olFldr = Nothing

 

[jbenner]

Thank you! Thank you! Thank you! You have no idea how long I have spent trying to find the solution to this same problem! Your wonderfully concise code actually worked! Just out of curiosity though I noticed that you had GetDefaultFolder(9) specified. How did you determine that it should be 9? NONE of the other code I looked at mentioned this. I suspect the lack of that may have been causing several errors for me.

 

[Ade F]

http://msdn.microsoft.com/en-us/library/office/aa220100(v=office.11).aspx

Hope this helps.

Basically I experimented until I found the correct number for the outlook default calendar then used this to then move down to the custom calendar. In my case a google apps calendar. Which works great as the google calendar then syncs effortlessly across our devices.

Glad to see it helped anyway.