• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 134
  • Last Modified:

Need to add appointment to outlook shared calendar from access

I need to be able to pull up the shared calendars and then choose one to add the appointment to.
Here is what i am working with:
Dim outobj As Outlook.Application
            Dim outappt As Outlook.AppointmentItem
            Set outobj = CreateObject("outlook.application")
            Set outappt = outobj.CreateItem(olAppointmentItem)
            With outappt
               .Start = Me!ApptDate & " " & Me!ApptTime
               .Duration = Me!ApptLength
               .Subject = Me!Appt
               If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNotes
               If Not IsNull(Me!ApptLocation) Then .Location = _
                  Me!ApptLocation
               If Me!ApptReminder Then
                  .ReminderMinutesBeforeStart = Me!ReminderMinutes
                  .ReminderSet = True
               End If
               .Save
            End With
0
VGuerra67
Asked:
VGuerra67
  • 5
  • 3
1 Solution
 
SimonCommented:
You need the Namespace.Pickfolder method for this

I don't have it in front of me but have working code for this...

First get the MAPI namespace for your Outlook application object.

The use its pickfolder method to return an object variable to the folder you want, which can be in the user's mailbox or any shared mailbox that they have access to.
0
 
VGuerra67Author Commented:
Thanks for the update if you have some code that would be great
0
 
SimonCommented:
Ok, here is some code. To use it, paste it into a new module in your Access database, and add a reference to the Microsoft Outlook object library (VBE/Tools/References).
It uses a lookup to get the mailbox EntryID from a lookup table based on the mailbox email address, and if it can't find one, it prompts the user to pick a folder. If it has to prompt for a folder it write the EntryID of the folder you chose to the immediate window so you can copy it to a lookup table to avoid being prompted each time.

Option Compare Database
Option Explicit

Sub test_Createappointment()
Dim retVal As String
retVal = CreatePublicCalendarAppt("GenericBox.test@domain.net", #1/17/2015 12:00:00 PM#, #1/18/2015 1:45:00 PM#, "Title", "Loc", "Text ")
Debug.Print retVal
End Sub

Function CreatePublicCalendarAppt(CalendarName As String, apptStartDate As Date, apptEndDate As Date, _
apptTitle As String, apptLocation As String, apptBody As Variant, Optional isAllDayEvent As Variant)
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim objDummy As Outlook.MailItem
    Dim objRecip As Outlook.Recipient
    Dim objAppt As Outlook.AppointmentItem
    Dim strMsg As String
    Dim strName As String
    Dim GUID As String 'Unique ID of the item created
    Dim folderID As Variant 'Unique ID of the folder object in the mail store

    strName = CalendarName
    
    If IsMissing(isAllDayEvent) Then
        isAllDayEvent = False
    Else
        isAllDayEvent = CBool(isAllDayEvent)
    End If
    
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set objDummy = objApp.CreateItem(olMailItem)
    Set objRecip = objDummy.Recipients.Add(strName)
    objRecip.Resolve
    If objRecip.Resolved Then
        folderID = DLookup("strValue", "tblConfigValues", "ConfigGroup='SharedCalendarNames' AND strLabel='" & strName & " EntryID'")
        If Not IsNull(folderID) Then
            Set objFolder = objNS.GetFolderFromID(folderID)
        End If

        '*********************
        'Use line below to pick the folder then get its EntryID. Can then set reference to it.
        If objFolder Is Nothing Then
        Set objFolder = _
          objNS.PickFolder
          If Not objFolder Is Nothing Then
            Debug.Print "Picked folder: EntryID = " & objFolder.EntryID 'Store this in a lookup table to avoid being prompted to pick a folder each time
            Debug.Print "Picked folder: FolderPath = " & objFolder.folderPath
        Else
            Debug.Print "No Folder picked"
            CreatePublicCalendarAppt = ""
            Exit Function
          End If
        End If
        '*********************

On Error GoTo 0
        
        If Not objFolder Is Nothing Then
            Set objAppt = objFolder.items.Add
            If Not objAppt Is Nothing Then
                With objAppt
                    .Subject = apptTitle
                    .Location = apptLocation
                    .Body = apptBody
                    .AllDayEvent = isAllDayEvent
                    .Start = apptStartDate
                    'Don't add end or it cannot be saved as allday event!!!
                    If Not isAllDayEvent Then
                        .End = apptEndDate
                    End If
                    'Add custom property to store GlobalAppointmentID as text string (as opposed to binary)
                    .ItemProperties.Add "GAI", olText, True
                    .save
                    GUID = .GlobalAppointmentID
                    .ItemProperties.Item("GAI").Value = GUID
                    .save
                    '.Display
                End With
            End If
        Else
            If objRecip Is Nothing Then
                MsgBox "Could not get calendar for " & strName ' VM 2012-09-12 Added to cater for objRecip is Nothing
            Else
                MsgBox "Could not get calendar for " & objRecip.Name ' VM if outlook unable to open, Error 91 Object variable or With block variable not set
            End If
        End If
    Else
        MsgBox "Could not find " & Chr(34) & strName & Chr(34), , _
               "CreatePublicCalendarAppt: User or object not found"
    End If

    Set objApp = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    Set objDummy = Nothing
    Set objRecip = Nothing
    Set objAppt = Nothing
    
    CreatePublicCalendarAppt = GUID
End Function

Open in new window

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
VGuerra67Author Commented:
After I copied and pasted your code.  I am getting an error message for "tblconfigvalues". What should be in this table?
0
 
SimonCommented:
Please comment out lines 37 to 40 of the code in the listing above for the moment.
ie. These ones....
        folderID = DLookup("strValue", "tblConfigValues", "ConfigGroup='SharedCalendarNames' AND strLabel='" & strName & " EntryID'")
        If Not IsNull(folderID) Then
            Set objFolder = objNS.GetFolderFromID(folderID)
        End If

Open in new window


I can provide the table definition tomorrow, but for testing purposes you can comment that out and it will then prompt you to pick the calendar folder to add the apppointment to.

The configtable allows you to store the EntryID for calendars you work with regularly to save you having to pick the folder from the PickFolder dialog.
0
 
SimonCommented:
Here's a sample of the config table entry that I use
tblConfigValues.pngThe first time you run this you need to step through the code and view the immediate window to get the ENTRYID for your shared calendar. You can then save that to a config table and look it up during subsequent runs.
0
 
VGuerra67Author Commented:
I am not sure what i am doing wrong.  However, i still can only get to my calender when the piicked folder option comes up.
The calendars that i am trying to put the appointments in are shared calendars they are not public.  I don't know if that makes a difference.
My objective is to create an access 2013 event that will populate an appointment in an outlook shared calendar.   I would like to be able to select which calendar in the event that i have multiple to choose from
0
 
SimonCommented:
Have you copied the value for EntryID and inserted it into the tblConfigValues?

When you call the function you should pass the generic account's email address as the first param
retVal = CreatePublicCalendarAppt("GenericBox.test@domain.net",

Open in new window


These lines are where your saved EntryID is looked up and used to set a reference to the folder, using the GetFolderFromID method.
    If objRecip.Resolved Then
        folderID = DLookup("strValue", "tblConfigValues", "ConfigGroup='SharedCalendarNames' AND strLabel='" & strName & " EntryID'")
        If Not IsNull(folderID) Then
            Set objFolder = objNS.GetFolderFromID(folderID)
        End If

Open in new window

0

Featured Post

Fill in the form and get your FREE NFR key NOW!

Veeam is happy to provide a FREE NFR server license to certified engineers, trainers, and bloggers.  It allows for the non‑production use of Veeam Agent for Microsoft Windows. This license is valid for five workstations and two servers.

  • 5
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now