We help IT Professionals succeed at work.

Send MS Access Appointments to Outlook Calendar - Output to Shared Calendar in Exchange

jfer0x01
jfer0x01 asked
on
2,450 Views
Last Modified: 2013-11-27
I have a MS Access 2003 DB that can talk to a Outlook calendar, by using this code
from
http://www.access-programmers.co.uk/forums/showthread.php?t=31517


Private Sub AddAppt_Click()
' Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
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
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub

Like my other post, I can get this code to add appointment in an Outlook Calendar, but, the calendar I need to get it to work on, is shared in Exchange as "User Calendar", for example, which I already have access to read and write to.

This code, only works on the default calendar in Outlook, which is not the one I need to make appointments in.

And, I cannot simply make it the default calendar, because the application will talk to more than one Calendar, using the same code

Any Ideas?

Jfer
Comment
Watch Question

CERTIFIED EXPERT

Commented:
To get a shared calendar folder (ie a delegate) you need to use the "GetSharedDefaultFolder" method.

this below can be added to get that folder and then get your new appointment and goes before your "With outappt"

Strname should be an email address.  I found this works the best.

Set objNS = objApp.GetNamespace("MAPI")

Set objRecip = objNS.CreateRecipient(strName)


Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)

If Not objFolder Is Nothing Then
    Set objAppt = objFolder.Items.Add
    End If

Commented:
I had a similar problem.  Using the code below, with the Folders("foldername") heirarchy leading up to the custom folder/calendar, works pretty dang well.  If you turn on your Web toolbar in Outlook (View->Toolbars->Web) and navigate to your desired calendar, it will display the heirarchy to get there.

In the case of the code below, for example, the heirarchy would be:
outlook:\\Public Folders\All Public Folders\Workgroup Folders\A - Ae\TEAM TWO

Hope this helps!
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.Folder
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Dim objAppt As Outlook.AppointmentItem
 
Set objFolder = objNS.Folders("Public Folders").Folders("All Public Folders").Folders("Workgroup Folders").Folders("A - Ae").Folders("TEAM TWO")
 
Set objAppt = objFolder.Items.Add()

Open in new window

CERTIFIED EXPERT
Top Expert 2009

Commented:
You might also be able to use the PickFolder method to select the folder from a dialog, using the code below (modify as needed depending on the type of folder you want to open):

Private Sub cmdOutlookFolder_Click()
'Created by Helen Feddema 9-Aug-2008
'Last modified 9-Aug-2008
 
On Error GoTo ErrorHandler
   
   Dim nms As Outlook.NameSpace
   
   Set appOutlook = New Outlook.Application
   Set nms = appOutlook.GetNamespace("MAPI")
   
SelectFolder:
   Set pfld = nms.PickFolder
   If pfld Is Nothing Then
      MsgBox "Please select a Contacts folder"
      GoTo SelectFolder
   End If
 
   Debug.Print "Default item type: " & pfld.DefaultItemType
   If pfld.DefaultItemType <> olContactItem Then
      MsgBox "Please select a Contacts folder"
      GoTo SelectFolder
   End If
 
   'For tblInfo
   Me![txtSelectedFolder].Value = pfld.Name
   
   'For database property
   strFolderPath = pfld.FolderPath
   strPropertyName = "FolderPath"
   lngDataType = dbText
   Call SetProperty(strPropertyName, lngDataType, _
      strFolderPath)
            
ErrorHandlerExit:
   Exit Sub
 
ErrorHandler:
   'Outlook is not running; open Outlook with CreateObject
   If Err.Number = 429 Then
      Set appOutlook = CreateObject("Outlook.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
 
End Sub

Open in new window

Author

Commented:
Thank you both,

I will try code tomorrow morning

Jfer

Author

Commented:
Correction,

all three of you

Author

Commented:
Spade86,

your code seems to be headed in the direction I want

Problem is

i receive a "User-defined Type not defined error" on Line 3, so IO replace "Folder", with "Folders"

then I receive a Type Mismatch on Line 8

Any thoughts?

Jfer

Commented:
Probably a Reference issue (under Tools -> References), sorry I've got a few going on that project....

It's probably the Microsoft Outlook 12.0 Object Library reference.  Other references I've got switched on include:
- Microsoft ActiveX Data Objects 2.8 Library
- Microsoft Access 12.0 Object Library
- Microsoft DAO 3.6 Object Library
- OLE Automation

Commented:
Outta curiosity, did it work?

Author

Commented:
No,

I have tried hardcoding the path to the calendar, but I do not know how to get the

Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)

linked with the

Set objFolder = objNS.Folders("Public Folders").Folders("All Public Folders").Folders("Workgroup Folders").Folders("A - Ae").Folders("TEAM TWO")

It seems I only have Outlook Object ver 11, not 12. Cant Update Sericvec Packs unfortunately.

Also Access 2003.

Jfer
 
Commented:
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION

Commented:
but wait, also, you did declare the namespace in that other code right?  

Dim objNS As Outlook.NameSpace
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

And of course, you're supposed to replace all of MY folder names with YOUR folder names in the line below... lol but I'm pretty sure you must have already known that....

Set objFolder = objNS.Folders("Public Folders").Folders("All Public Folders").Folders("Workgroup Folders").Folders("A - Ae").Folders("TEAM TWO")

Author

Commented:
So I tried your script,

but, it returns no action,

I only made minor modifications, in terms of appointment variables I added, and obviously, the path to calendar.

I'll probably see it a gain in about 1 1/2 though.

Seemed Like it would work thought, but click action does nothing, and yes I made sure the Script was in the desired action

Jfer

Commented:
Sorry I didn't touch on this before, I overlooked it.  Problem best guess:

      If (objFolder = jobrole) Then 'We found it!

Change the jobrole variable to the exact name of the calendar you're attempting to access, e.g. (objFolder = "Team 51 Sales Calls"), etc.

Author

Commented:
Ok, Ill have to try it later no the week

Thank you for all your help.

Hope this solves my problem.

Jfer

Author

Commented:
It did work after all

Thanks Again!!!

Jfer
Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.