Class: OutlookCalendar in Category Microsoft Outlook : Automation from Total Visual SourceBook

Working with Microsoft Outlook Calendars through Automation using VBA and VB6.

Procedure Name Type Description
(Declarations) Declarations Declarations and private variables for the COutlookCalendar class.
AppOutlook Property Get a handle to the current instance of Outlook.
AppNameSpace Property Get a handle to the current instance of the Outlook NameSpace.
AddAppointment Method Adds an appointment without attachments to the calendar.
AddMeetingRequest Method Adds an appointment without attachments to the calendar.
EditAppointmentTime Method Change the start time of the first appointment that meets the specified subject and date range.
GetAppointmentID Method Get the Global Appointment ID of the first Appointment Item with the specified subject. The problem with this ID is that Outlook doesn't allow searching appointments using this ID since it's stored as a binary.
GetAppointmentItem Method Get the first appointment item the specified criteria. With the item, you can edit its properties directly.
GetAppointmentInfo Method Get the first appointment that meets the specified subject and date range, and set values from it.
DeleteAppointments Method Delete all appointments with the subject name from the calendar in the date range specified. If you delete a meeting request, a cancel meeting is sent.
CancelMeetings Method Cancel and send cancellation notice, but do not delete all meetings with the subject name in the date range specified.
GetMeetingRequests Method Get the list of meeting requests from the InBox for a specific subject and/or received date range.
RespondToMeetingRequest Method Respond to the meeting requests in the Inbox for the subject and date range specified.
IsTimeAvailable Method Checks if there is an existing appointment within the specified date range with an option to ignore appointments flagged as free. If no end date is passed, we just check datFromDate.

Values Passed Return Value
Start End  
10:00 AM No Value (Assume 10:01) IsAvailable = False
10:30 AM No Value (Assume 10:31) IsAvailable = True
10:00 AM 10:00 AM IsAvailable = True
10:30 AM 10:30 AM IsAvailable = True
10:01 AM 10:02 AM IsAvailable = False
9:30 AM 10:00 AM IsAvailable = True
9:30 AM 10:01 AM IsAvailable = False
10:30 AM 10:31 AM IsAvailable = True
10:29 AM 10:31 AM IsAvailable = False
9:00 AM 11:00 AM IsAvailable = False
GetCalendarItems Method Get a list of all calendar items with start dates OR end dates within the specified date range.
GetCalendarFilter Private Create the filter string to limit the calendar items to a date range, but also include items that span the range.
StartOutlook Method Starts an instance of Outlook.
Class_Terminate Terminate Clean up class variables opened for Outlook.
CloseOutlook Method Close an instance of Outlook; don't call this if you want to leave Outlook open.
' Example of the COutlookCalendar class
'
' To try this example, do the following:
' 1. Create a new form
' 2. Add the following text boxes:
'       txtSubject
'       txtAttach
'       txtLocation
'       txtStart
'       txtDuration
'       txtRemindMin
'       txtRecipients
'       txtBody
' 3. Add the following command buttons:
'       cmdAdd
'       cmdDelete
'       cmdSend
'       cmdCancel
'       cmdRespond
'       cmdGetInfo
'       cmdList
'       cmdIsAvailable
'       cmdEdit
'       cmdEditSetTime
' 4. Paste all the code from this example to the new form's module
' 5. Run the form

Private Const mcstrSampleDir As String = "C:\Total Visual SourceBook 2013\Samples\"

Private Sub cmdAdd_Click()
  ' Add a standard appointment

  Dim strSubject As String
  Dim fOK As Boolean
  Dim clsOutlookCalendar As COutlookCalendar

  strSubject = Me.txtSubject

  If MsgBox("Are you sure you want to add " & strSubject & " to your calendar for " & Me.txtStart & "?", vbYesNo) = vbYes Then
    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    fOK = clsOutlookCalendar.AddAppointment(strSubject, Me.txtStart, Me.txtDuration, Me.txtRemindMin, False, olBusy, Me.txtBody, Me.txtLocation, , , True)

    MsgBox "Appointment added successfully: " & fOK

    ' Clean up
    Set clsOutlookCalendar = Nothing
  End If

End Sub

Private Sub cmdDelete_Click()
  ' Delete Appointments

  Dim strSubject As String
  Dim fOK As Boolean
  Dim clsOutlookCalendar As COutlookCalendar

  strSubject = Me.txtSubject

  If MsgBox("Are you sure you want to delete meetings over the next two days with the subject " & strSubject & " from your calendar?", vbYesNo) = vbYes Then
    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    fOK = clsOutlookCalendar.DeleteAppointments(strSubject, Date, Date + 2)

    MsgBox "Meetings deleted successfully: " & fOK

    ' Clean up
    Set clsOutlookCalendar = Nothing
  End If

End Sub

Private Sub cmdEdit_Click()
  ' Edit an existing appointment by directly modifying the appointment object

  Dim strSubject As String
  Dim clsOutlookCalendar As COutlookCalendar
  Dim outItem As Outlook.AppointmentItem

  strSubject = Me.txtSubject

  If MsgBox("Do you want to add an hour to the start time of the first appointment over the next two days with the subject " & strSubject & "?", vbYesNo) = vbYes Then
    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    Set outItem = clsOutlookCalendar.GetAppointmentItem(strSubject, -1, Date, Date + 2, False)

    If outItem Is Nothing Then
      MsgBox "Appointment was not found"
    Else
      With outItem
        ' Add one hour as a fraction of a day's 24 hours
        .Start = .Start + (1 / 24)
        .Save
        MsgBox "Appointment time updated successfully to " & .Start & " and " & .End
      End With
    End If

    ' Clean up
    Set outItem = Nothing
    Set clsOutlookCalendar = Nothing

  End If

End Sub

Private Sub cmdEditSetTime_Click()
  ' Edit an existing appointment by using a function to set a specific time

  Dim strSubject As String
  Dim clsOutlookCalendar As COutlookCalendar
  Dim strNewTime As String
  Dim datNew As Date

  strSubject = Me.txtSubject

  If MsgBox("Do you want to set the time of the first appointment over the next two days with the subject " & strSubject & "?", vbYesNo) = vbYes Then
    strNewTime = InputBox("Enter the new time for the appointment", , Now + 1)
    If strNewTime <> "" Then
      datNew = CDate(strNewTime)

      ' Initialize Calendar class and connect to Outlook
      Set clsOutlookCalendar = New COutlookCalendar
      clsOutlookCalendar.StartOutlook

      If clsOutlookCalendar.EditAppointmentTime(strSubject, Date, Date + 2, False, datNew, True) Then
        MsgBox "Appointment was successfully updated"
      Else
        MsgBox "No appointment was updated"
      End If

      ' Clean up
      Set clsOutlookCalendar = Nothing
    End If
  End If

End Sub

Private Sub cmdGetInfo_Click()
  ' Get Meeting information

  Dim strSearchSubject As String
  Dim clsOutlookCalendar As COutlookCalendar
  Dim datStart As Date
  Dim datEnd As Date
  Dim strBody As String
  Dim fAllDayEvent As Boolean
  Dim eMeetingStatus As OlMeetingStatus, eBusyStatus As OlBusyStatus
  Dim strMsg As String

  strSearchSubject = Me.txtSubject

  If MsgBox("Do you want to retrieve information on the first meeting in the next two days with the subject " & strSearchSubject & "?", vbYesNo) = vbYes Then
    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    If clsOutlookCalendar.GetAppointmentInfo(strSearchSubject, Date, Date + 2, False, datStart, datEnd, fAllDayEvent, eMeetingStatus, eBusyStatus, strBody) Then
      strMsg = "Meeting '" & strSearchSubject & "' found:" & vbCrLf & _
               "Start time: " & datStart & vbCrLf & _
               "End time: " & datEnd & vbCrLf & _
               "AllDayEvent: " & fAllDayEvent & vbCrLf & _
               "Meeting Status: " & eMeetingStatus & vbCrLf & _
               "Busy Status: " & eBusyStatus & vbCrLf & _
               "Body: " & strBody & vbCrLf
      MsgBox strMsg
    Else
      MsgBox "Meeting '" & strSearchSubject & "' not found."
    End If

    ' Clean up
    Set clsOutlookCalendar = Nothing
  End If
End Sub

Private Sub cmdSend_Click()
  ' Send Meeting Request

  Dim fOK As Boolean
  Dim clsOutlookCalendar As COutlookCalendar

  If MsgBox("Are you sure you want to send a meeting request to " & Me.txtRecipients & "?", vbYesNo) = vbYes Then
    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    fOK = clsOutlookCalendar.AddMeetingRequest(True, Me.txtRecipients, Me.txtSubject, Me.txtStart, Me.txtDuration, Me.txtRemindMin, False, olBusy, "", Me.txtLocation)

    MsgBox "Meeting request added successfully: " & fOK

    ' Clean up
    Set clsOutlookCalendar = Nothing

  End If

End Sub

Private Sub cmdCancel_Click()
  ' Cancel Meetings

  Dim strSubject As String
  Dim fOK As Boolean
  Dim clsOutlookCalendar As COutlookCalendar

  strSubject = Me.txtSubject

  If MsgBox("Are you sure you want to cancel (without deleting) all of the meetings over the next two days with the subject " & strSubject & "?", vbYesNo) = vbYes Then
    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    fOK = clsOutlookCalendar.CancelMeetings(strSubject, Date, Date + 2)

    MsgBox "Meeting canceled successfully: " & fOK

    ' Clean up
    Set clsOutlookCalendar = Nothing
  End If

End Sub

Private Sub cmdRespond_Click()
  ' Respond to Meeting Request

  Dim clsOutlookCalendar As COutlookCalendar
  Dim colItems As Collection
  Dim lngRequests As Long
  Dim strMsg As String
  Dim lngResponses As Long

  ' Initialize Calendar class and connect to Outlook
  Set clsOutlookCalendar = New COutlookCalendar
  clsOutlookCalendar.StartOutlook

  ' Retrieve all meeting requests received from the past day
  Set colItems = clsOutlookCalendar.GetMeetingRequests("", Now - 1, Now)

  If colItems Is Nothing Then
    MsgBox "No meeting requests found"
  ElseIf colItems.Count = 0 Then
    MsgBox "No meeting requests found"
  Else
    strMsg = ""
    For lngRequests = 1 To colItems.Count
      With colItems(lngRequests)
        strMsg = vbCrLf & "Received time: " & .ReceivedTime & " Subject: " & .Subject
      End With
    Next lngRequests
    MsgBox "Meeting requests found: " & strMsg

    If MsgBox("Are you sure you want to accept all these meeting requests?", vbYesNo) = vbYes Then
      lngResponses = clsOutlookCalendar.RespondToMeetingRequest(olMeetingAccepted, "", Date, Date + 1)
      MsgBox "Meeting responses sent: " & lngResponses
    End If
  End If

  ' Clean up
  Set clsOutlookCalendar = Nothing

End Sub

Private Sub cmdList_Click()
  ' List Calendar Items

  Dim strReturn As String
  Dim datCheck As Date
  Dim clsOutlookCalendar As COutlookCalendar
  Dim col As Collection
  Dim intCounter As Integer
  Dim strMsg As String

  strReturn = InputBox("Enter the date to check", "", Date)
  If strReturn <> "" Then
    datCheck = CDate(strReturn)

    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    ' Get Calendar items
    Set col = clsOutlookCalendar.GetCalendarItems(datCheck, datCheck + 1)

    ' Clean up
    Set clsOutlookCalendar = Nothing

    strMsg = "Calendar items on " & datCheck & ":" & vbCrLf
    If col.Count = 0 Then
      strMsg = strMsg & "None found"
    Else
      For intCounter = 1 To col.Count
        With col(intCounter)
          strMsg = strMsg & vbCrLf & .Subject & " from " & .Start & " to " & .End
        End With
      Next intCounter
    End If

    MsgBox strMsg

  End If

End Sub

Private Sub cmdIsAvailable_Click()
  ' Is Date/Time Available

  Dim strReturn As String
  Dim datCheck As Date
  Dim clsOutlookCalendar As COutlookCalendar

  strReturn = InputBox("Enter the date to check for availability", "", Date)
  If strReturn <> "" Then
    datCheck = CDate(strReturn)

    ' Initialize Calendar class and connect to Outlook
    Set clsOutlookCalendar = New COutlookCalendar
    clsOutlookCalendar.StartOutlook

    If clsOutlookCalendar.IsTimeAvailable(datCheck) Then
      MsgBox datCheck & " IS available."
    Else
      MsgBox datCheck & " IS NOT available."
    End If

    ' Clean up
    Set clsOutlookCalendar = Nothing
  End If

End Sub

Private Sub Form_Load()

  Const cintWidth As Integer = 3000
  Const cintLeftText As Integer = 100
  Const cintLeftButton As Integer = 3500

  ' Setup controls
  With Me.txtSubject
    .StatusBarText = "Subject"
    .ControlTipText = "Subject"
    .Top = 100
    .Left = cintLeftText
    .Width = cintWidth
    .Value = "Test Meeting Subject"
  End With
  With Me.txtAttach
    .StatusBarText = "Attachments (separated by ;)"
    .ControlTipText = "Attachments (separated by ;)"
    .Top = 500
    .Left = cintLeftText
    .Width = cintWidth
    .Value = mcstrSampleDir & "Test.txt"
  End With
  With Me.txtLocation
    .StatusBarText = "Location"
    .ControlTipText = "Location"
    .Top = 900
    .Left = cintLeftText
    .Width = cintWidth
    .Value = "Test Meeting Location"
  End With
  With Me.txtStart
    .StatusBarText = "DateStart"
    .ControlTipText = "DateStart"
    .Format = "m/d/yyyy h:m"
    .Top = 1300
    .Left = cintLeftText
    .Width = 2000
    .Value = Format$(Now() + 1, "m/d/yyyy h:m")
  End With
  With Me.txtDuration
    .StatusBarText = "Duration"
    .ControlTipText = "Duration"
    .Format = "#"
    .Top = 1700
    .Left = cintLeftText
    .Width = 750
    .Value = 30
  End With
  With Me.txtRemindMin
    .StatusBarText = "Reminder Minutes (0 for no reminder)"
    .ControlTipText = "Reminder Minutes (0 for no reminder)"
    .Format = "#"
    .Top = 2100
    .Left = cintLeftText
    .Width = 750
    .Value = 15
  End With
  With Me.txtRecipients
    .StatusBarText = "Recipients (separated by ;)"
    .ControlTipText = "Recipients (separated by ;)"
    .Top = 2500
    .Left = cintLeftText
    .Width = cintWidth
    .Value = "Test1@fmsinc.com;Test2@fmsinc.com"
  End With
  With Me.txtBody
    .StatusBarText = "Body"
    .ControlTipText = "Body"
    .Top = 2900
    .Left = cintLeftText
    .Width = cintWidth
    .Height = 1250
    .Value = "This is a test meeting. Please remember to delete it from your calendar after you are done testing this code."
  End With

  ' Command buttons
  With Me.cmdAdd
    .Top = 100
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Add Appointment"
  End With
  With Me.cmdDelete
    .Top = 600
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Delete Appointment"
  End With
  With Me.cmdSend
    .Top = 1100
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Send Meeting Request"
  End With
  With Me.cmdCancel
    .Top = 1600
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Cancel Meeting"
  End With
  With Me.cmdRespond
    .Top = 2100
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Respond to Meeting Request"
  End With
  With Me.cmdGetInfo
    .Top = 2600
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Get Meeting Information"
  End With
  With Me.cmdList
    .Top = 3100
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "List Calendar Items"
  End With
  With Me.cmdIsAvailable
    .Top = 3600
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Is Date/Time Available"
  End With
  With Me.cmdEdit
    .Top = 4100
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Edit Appointment Add Hour"
  End With
  With Me.cmdEditSetTime
    .Top = 4600
    .Left = cintLeftButton
    .Width = cintWidth
    .Caption = "Edit Appointment Set Time"
  End With

End Sub

Total Visual SourceBook The source code in Total Visual Sourcebook includes modules and classes for Microsoft Access, Visual Basic 6 (VB6), and Visual Basic for Applications (VBA) developers. Easily add this professionally written, tested, and documented royalty-free code into your applications to simplify your application development efforts.

Total Visual SourceBook is written for the needs of a developer using a source code library covering the many challenges you face. Countless developers over the years have told us they learned some or much of their development skills and tricks from our code. You can too!

Additional Resources

Total Visual SourceBook CD and Printed Manual

Microsoft Access/ Office 2016, 2013, 2010, and 2007 Version
is Shipping!

New features in Total Visual SourceBook for Access, Office and VB6

Supports Access/Office 2016, 2013, 2010 and 2007, and Visual Basic 6.0!


View all FMS products for Microsoft Access All Our Microsoft Access Products

Reviews

Reader Choice Award for MS Access Source Code Library
Reader Choice

"The code is exactly how I would like to write code and the algorithms used are very efficient and well-documented."

Van T. Dinh, Microsoft MVP

SourceBook Info

Additional Info

Question

 

 

Free Product Catalog from FMS