Adding Appointment from Access to Outlook on Another Persons Calendar

Posted on 2008-06-24
Last Modified: 2013-11-27
I am trying to get Access to put an appointment onto another person's calendar in outlook.  I have a form that you choose who you want to add the appointment to, however, when the code searches for the Mailbox for the person selected it can not find it.

Pleae note that I am relatively new to VBA for Access

The code I am using is below...most of which I have goten off this website and a few others.

Please help,

****CODE START****

Option Explicit

Dim outObj As New Outlook.Application

Dim outNS As Outlook.NameSpace

Dim outFolders As Outlook.MAPIFolder

Dim outSubFolders As Outlook.MAPIFolder

Dim outAppt As Outlook.AppointmentItem

Dim strMail, strFirst, strLast As String

Dim intCount As Integer

Dim frm As Form

Function addAppt()

' Save record first to be sure required fields are filled.

    DoCmd.RunCommand acCmdSaveRecord

' Exit the procedure if appointment has been added to Outlook.

    Set frm = Screen.ActiveForm


    If frm.AddedToOutlook = True Then

        MsgBox "This appointment already added to Microsoft Outlook"

        Exit Function


'Set the name of the Mailbox


        strMail = frm.Auditor.Text

        intCount = InStrRev(strMail, " ")

        strFirst = Trim$(Left$(strMail, intCount))

        strLast = Trim$(Right$(strMail, intCount))

        strMail = "Mailbox - " & strLast & ", " & strFirst


' Add a new appointment.

        Set outNS = outObj.GetNamespace("MAPI")

        Set outFolders = outNS.Folders(strMail)

        Set outSubFolders = outFolders.Folders("Calendar")

        Set outAppt = outObj.CreateItem(olAppointmentItem)

        With outAppt

           .Start = frm.ApptDate & " " & frm.ApptTime

           .Duration = frm.ApptLength

           .Subject = frm.Appt

           If Not IsNull(frm.ApptNotes) Then .Body = frm.ApptNotes

           If Not IsNull(frm.ApptLocation) Then .Location = _


           If frm.ApptReminder Then

              .ReminderMinutesBeforeStart = frm.ReminderMinutes

              .ReminderSet = True

           End If


        End With

    End If

    ' Release the Outlook object variable.

    Set outObj = Nothing

    ' Set the AddedToOutlook flag, display a message.

    frm.AddedToOutlook = True

    DoCmd.RunCommand acCmdSaveRecord

    MsgBox "Appointment Added!"

    Exit Function


    MsgBox "Error " & Err.Number & vbCrLf & Err.Description

    Exit Function

End Function

****CODE END****

Open in new window

Question by:BVass
1 Comment
LVL 74

Accepted Solution

Jeffrey Coachman earned 500 total points
Comment Utility

This Question is almost Identical.
Try the solution:


Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Overview: This article:       (a) explains one principle method to cross-reference invoice items in Quickbooks®       (b) explores the reasons one might need to cross-reference invoice items       (c) provides a sample process for creating a M…
Over the years I have built up my own little library of code snippets that I refer to when programming or writing a script.  Many of these have come from the web or adaptations from snippets I find on the Web.  Periodically I add to them when I come…
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now