Creating Vacation Schedule with Approval in Outlook from Access

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?

K
Karen SchaeferBI ANALYSTAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Scott McDaniel (Microsoft Access MVP - EE MVE )Infotrakker SoftwareCommented:
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
0
Helen FeddemaCommented:
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")
   rst.MoveLast
   rst.MoveFirst
   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)
            rcp.Resolve
            If rcp.Resolved Then
               .Links.Add rcp
            Else
               MsgBox "Can't add " & strContactName & _
                  " as a contact for this appointment"
            End If
         End If
         .Close (olSave)
      End With
      rst.MoveNext
   Loop
   rst.Close

ErrorHandlerExit:
   Exit Sub

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

End Sub

Open in new window

0
Helen FeddemaCommented:
I forgot the line to set appOutlook (it was set globally in my module).  Declare appOutlook as New Outlook.Application.
0
Helen FeddemaCommented:
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")

SelectFolder:
   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)
         
NextItemTask:
      .MoveNext
      Loop
      .Close
   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."
   Else
      strPrompt = "All tasks created in " & strFolderName & " folder"
   End If
      
   MsgBox strPrompt, vbOKOnly + vbInformation, strTitle
   
ErrorHandlerExit:
   Exit Sub

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

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Karen SchaeferBI ANALYSTAuthor Commented:
thanks for the assist
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.