Creating Vacation Schedule with Approval in Outlook from Access

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

Select allOpen in new window