Creating Vacation Schedule with Approval in Outlook from Access

Posted on 2010-04-09
Medium Priority
Last Modified: 2013-11-27
I am looking for code that will allow me to create in Access an vacation scheduling tool that will use the OUTLOOK options/data to send request for approval and then update the users Outlook calendar upon approval.  I have seen many examples of the basic code for Access to send emails using Outlook, however, unable to find the functionality need to calendar/email notifications.

Can someone help point me in the right direction?

Question by:Karen Schaefer
  • 3
LVL 85
ID: 30221863
You need to add Appointments or Events to Outlook it seems.

Add Appointments: http://support.microsoft.com/?kbid=209963
Add Tasks/Events: http://support.microsoft.com/?kbid=162371
LVL 31

Expert Comment

by:Helen Feddema
ID: 30431253
Here is some code to create appointments with reminders
Public Sub ExportCalendar()
'Created by Helen Feddema 5-19-2000
'Last modified 11-Apr-2010

On Error GoTo ErrorHandler

   Dim appOutlook As New Outlook.Application
   Dim itm As Outlook.AppointmentItem
   Dim rcp As Outlook.Recipient
   Dim strContactName As String
   Dim strFolder As String
   Dim nms As Outlook.NameSpace
   Dim flds As Outlook.Folders
   Dim blnFound As Boolean
   Dim fld As Outlook.MAPIFolder
   Dim itms As Outlook.Items
   Dim appt As Outlook.AppointmentItem
   strFolder = "Appointments from Access"
   Set nms = appOutlook.GetNamespace("MAPI")
   Set flds = nms.Folders("Personal Folders").Folders
   Set nms = appOutlook.GetNamespace("MAPI")
   'Check for existence of Appointments from Access folder and
   'create it if not found
   blnFound = False
   For Each fld In flds
      If fld.Name = strFolder Then
         blnFound = True
      End If
   Next fld
   If blnFound = True Then
      Set fld = flds(strFolder)
   ElseIf blnFound = False Then
      Set fld = flds.Add(strFolder, olFolderCalendar)
   End If
   Set itms = fld.Items
   'Get reference to data table
   Set dbs = CurrentDb
   'Create recordset based on query
   Set rst = dbs.OpenRecordset("qryAppointments")
   lngCount = rst.RecordCount
   'Loop through table, exporting each record to Outlook
   Do Until rst.EOF
      'Create an appointment item
      Set appt = itms.Add("IPM.Appointment")
      With appt
         .Subject = Nz(rst![Topic])
         .Categories = Nz(rst![Category])
         .Start = Nz(rst![StartTime])
         .End = Nz(rst![EndTime])
         .Location = Nz(rst![Location])
         .ReminderMinutesBeforeStart = 20
         .ReminderOverrideDefault = True
         .ReminderPlaySound = True
         .ReminderSet = True
         .ReminderSoundFile = "C:\Windows\Media\Tada.wav"
         strContactName = Nz(rst![ContactName])
         Debug.Print "Contact name: " & strContactName
         If strContactName <> "" Then
            'The Links collection corresponds to the Contacts button
            'in the interface, and a link has to be a valid recipient,
            'so we have to check that the FullName value is a valid
            'Outlook contact before adding it as a link
            Set rcp = nms.CreateRecipient(strContactName)
            If rcp.Resolved Then
               .Links.Add rcp
               MsgBox "Can't add " & strContactName & _
                  " as a contact for this appointment"
            End If
         End If
         .Close (olSave)
      End With

   Exit Sub

   MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
   Resume ErrorHandlerExit

End Sub

Open in new window

LVL 31

Expert Comment

by:Helen Feddema
ID: 30431883
I forgot the line to set appOutlook (it was set globally in my module).  Declare appOutlook as New Outlook.Application.
LVL 31

Accepted Solution

Helen Feddema earned 2000 total points
ID: 30432844
Looking back, it is there.  It was missing from the Tasks procedure, posted below:
Public Sub CreateTasks()
'Created by Helen Feddema 11-Apr-2010
'Last modified by Helen Feddema 11-Apr-2010

On Error GoTo ErrorHandler

   Dim appOutlook As New Outlook.Application
   Dim blnSomeSkipped As Boolean
   Dim nms As Outlook.NameSpace
   Dim fld As Outlook.MAPIFolder
   Dim dbs As DAO.Database
   Dim rstData As DAO.Recordset
   Dim strTest As String
   Dim strTaskName As String
   Dim dteStartDate As Date
   Dim dteDueDate As Date
   Dim strFolderName As String
   Dim strStatus As String
   Dim lngStatus As Long
   Dim strDocsPath As String
   Dim tsk As Outlook.TaskItem
   blnSomeSkipped = False

   Set nms = appOutlook.GetNamespace("MAPI")

   Set fld = nms.PickFolder
   Debug.Print "Folder name: " & fld.Name
   If fld Is Nothing Then
      MsgBox "Please select a Tasks folder"
      GoTo SelectFolder
   End If

   Debug.Print "Default item type: " & fld.DefaultItemType
   If fld.DefaultItemType <> olTaskItem Then
      MsgBox "Please select a Tasks folder"
      GoTo SelectFolder
   End If
   Set dbs = CurrentDb
   Set rstData = dbs.OpenRecordset("tblTasks", dbOpenDynaset)
   With rstData
      Do While Not .EOF
         'Check for required task information
         strTest = Nz(![TaskName])
         Debug.Print "Task: " & strTest
         If strTest = "" Then
            blnSomeSkipped = True
            Print #1,
            Print #1, "No task name"
            GoTo NextItemTask
         End If
         strTaskName = Nz(![TaskName])
         dteStartDate = Nz(![StartDate])
         dteDueDate = Nz(![DueDate])
         strStatus = Nz(![Status])
         lngStatus = Switch(strStatus = "Not started", 0, _
            strStatus = "In progress", 1, _
            strStatus = "Completed", 2, "", 0)
         'Create new task item in selected Tasks folder
         Set tsk = fld.Items.Add
         tsk.Subject = strTaskName
         tsk.StartDate = dteStartDate
         tsk.DueDate = dteDueDate
         tsk.Status = lngStatus
         tsk.Close (olSave)
   End With

   strTitle = "Done"
   If blnSomeSkipped = True Then
      strPrompt = "All tasks created; some records skipped because " _
         & "of missing information." & vbCrLf & "See " & strDocsPath _
         & "Skipped Records.txt for details."
      strPrompt = "All tasks created in " & strFolderName & " folder"
   End If
   MsgBox strPrompt, vbOKOnly + vbInformation, strTitle
   Exit Sub

   MsgBox "Error No: " & Err.Number _
      & " in CreateTasks procedure; " _
      & "Description: " & Err.Description
   Resume ErrorHandlerExit

End Sub

Open in new window


Author Closing Comment

by:Karen Schaefer
ID: 31897645
thanks for the assist

Featured Post

Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A few solutions to a problem some of us have been having when trying to add Hostgator email accounts to Outlook 2016 (will probably work with Outlook 2013 as well).
Organisation is organized in a pattern to flow the day to day business, every application and system is interdepended on each other and when very important “Exchange Server downtime” happened.
Whether it be Exchange Server Crash Issues, Dirty Shutdown Errors or Failed to mount error, Stellar Phoenix Mailbox Exchange Recovery has always got your back. With the help of its easy to understand user interface and 3 simple steps recovery proced…
Watch the video to learn how one can deal with PST file corruption issue with an outstanding Kernel for Outlook PST Repair Tool easily. Using this tool, non-technical users can swiftly perform the repair process to restore their essential data witho…
Suggested Courses

593 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