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

' 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

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

• List of All Modules in Total Visual SourceBook
• List of All Code Categories in Total Visual SourceBook
• Sample Module Code from Total Visual SourceBook (Example of Date, Time and Age Calculations)