Choose Outlook Calendar

[Andrwal6]

Hello All
I'm using Windows 7 with MS Office 2010 pro.

I use the Sub routine below to send Appointments, created in my Access database to a Calendar in Outlook.

The line: {Set olFolder = outobj.GetNamespace("MAPI").pickFolder} allows me to chose which Calendar I want the appointment to go to from a choice of four sub Calendars in my Outlook. It works very well,
BUT:
Is there a way to change that line to automatically send appointment to a predetermined Calendar, Say, as an argument in the sub routine call?

Your help would be very much appreciated.
Andy.

Public Sub ApptToOutlook()
If Me.FittingToOutlook = True Then '**Flag
    MsgBox "Appointment Already Sent for This Fitting", vbOKOnly, "Too Late"
    Exit Sub
Else
        Dim Content As String
        Dim outobj As Object   ' *The Outlook.Application
        Dim outappt As Object  ' *The Outlook.AppointmentItem
        Dim olFolder As Object ' *The Required Folder/Calendar
        
        Content = Me.TeamLeader.Column(1) & vbCrLf
        Content = Content + DLookup("[ADDRESS]", "AddressConcatenation Query", "[ID] =" & Forms![Database]![ID]) & vbCrLf
        Content = Content + Nz(Forms![Database]![TEL NO]) & vbCrLf
        Content = Content + Nz(Forms![Database]![MOBILE])
                
        Set outobj = CreateObject("outlook.application")
        Set olFolder = outobj.GetNamespace("MAPI").pickFolder
        Set outappt = olFolder.Items.Add
        With outappt
            .Start = Me![Fitting Date] '& " " & "08:00"
            .End = Me.Fitting_Date + Me.FTGDays
            .AllDayEvent = True
            .Location = Forms![Database]![Town].Column(1)
            .Subject = Forms![Database]![TITLE] & " " & Forms![Database]![SURNAME] & ", Installation " & Me.TeamLeader.Column(1)
            .Body = Content
            .ReminderMinutesBeforeStart = 90
            .ReminderSet = False
            .Save
        End With
End If
         ' *Release the Outlook object variables.
         Set outobj = Nothing
         Set outappt = Nothing
         Set olFolder = Nothing
         Me.FittingToOutlook = True ' *Set Flag
         MsgBox "Fitting Date Sent to Outlook", vbOKOnly, "Appointment Sent"
End Sub

 

[stopher]

Does this help:
http://answers.microsoft.com/en-us/...r-folder/7c5826a3-b8f4-45a3-9d30-a6c2048625f0

 

[Andrwal6]

Thank you Stopher
I have gone round and round in circles trying to shoehorn lines like those, only to fail time and again with Object not Found or Doesn't support those properties etc. etc I have changed part of the code to that shown below but get RTE438 [Object doesn't support this property or method.]
I'm confused.

 Dim Content As String
        Dim outobj As Object   ' *The Outlook.Application
        Dim outappt As Object  ' *The Outlook.AppointmentItem
        Dim olFolder As Object ' *The Required Folder/Calendar
        Dim olItems As Outlook.Items
        
        Content = Me.TeamLeader.Column(1) & vbCrLf
        Content = Content + DLookup("[ADDRESS]", "AddressConcatenation Query", "[ID] =" & Forms![Database]![ID]) & vbCrLf
        Content = Content + Nz(Forms![Database]![TEL NO]) & vbCrLf
        Content = Content + Nz(Forms![Database]![MOBILE])
                
        Set outobj = CreateObject("outlook.application")
        Set olItems = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("Fitting").Items
        'Set olFolder = outobj.GetNamespace("MAPI").pickFolder
        'Set outappt = olFolder.Items.Add
        Set outappt = olItems.Items.Add
        With outappt
            .Start = Me![Fitting Date] '& " " & "08:00"
            .End = Me.Fitting_Date + Me.FTGDays 
ETC. Etc.

 

[stopher]

I haven't checked fully but I think you need something like this:

Set olFolder = outobj.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Parent.Folders("Fitting")

 

[Andrwal6]

Thank you so much Stopher.
I would not have come up with that concatenation in months.
It works perfectly. I can do the rest now.
Regards, Andy