CODEWITHSUNDEEP
excelvba
user1088793
user1088793

Reputation: 653

How to open the last appointment to confirm it was created?

I create and save an Outlook appointment with Excel VBA. I would like to see a confirmation that it has saved.

The closest I have come is displaying the Outlook calendar.

Private Sub CommandButton1_Click()
    
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    
    Set olApp = New Outlook.Application
    Set olApt = olApp.CreateItem(olAppointmentItem)
    
    With olApt
        .Start = Date + 1 + TimeValue("19:00:00")
        .End = .Start + TimeValue("00:30:00")
        .Subject = "Piano lesson"
        .Location = "The teachers house"
        .Body = "Don't forget to take an apple for the teacher"
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 120
        .ReminderSet = True
        .Save
    End With
    
    olApp.Session.GetDefaultFolder(olFolderCalendar).Display
    Set olApt = Nothing
    Set olApp = Nothing
        
End Sub

Upvotes: 1

Views: 344

Answers (1)

Ryan Wildry
Ryan Wildry

Reputation: 5677

You can construct a function that returns a boolean to indicate if the meeting exists or not. I made some assumptions, and made such a function. I've defined a matching meeting as one that has a matching: duration, date, and meeting Subject.

I just made this function return a Debug.Print, but once you know it exists, you can do whatever you like with this information.

Option Explicit

Public Sub Example()
    Dim olApp As Outlook.Application: Set olApp = New Outlook.Application
    Dim olApt As AppointmentItem: Set olApt = olApp.CreateItem(olAppointmentItem)
    Dim MeetingStartDate As Date: MeetingStartDate = Date + 1 + TimeValue("19:00:00")

    With olApt
        .Start = MeetingStartDate
        .End = .Start + TimeValue("00:30:00")
        .Subject = "Piano lesson"
        .Location = "The teachers house"
        .Body = "Don't forget to take an apple for the teacher"
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 120
        .ReminderSet = True
        .Save
    End With

    If MeetingExists(MeetingStartDate, 30, "Piano lesson") Then
        Debug.Print "The meeting exists!"
    Else
        Debug.Print "The meeting does not exist!"
    End If

End Sub

'Check all meetings for that day. A match is defined as having the same meeting subject and duration
'Adapted from: https://learn.microsoft.com/en-us/office/vba/outlook/how-to/search-and-filter/search-the-calendar-for-appointments-within-a-date-range-that-contain-a-specific
Public Function MeetingExists(StartDate As Date, Duration As Long, MeetingSubject As String) As Boolean
    MeetingExists = False
    Dim oCalendar               As Outlook.Folder: Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
    Dim oItems                  As Outlook.Items: Set oItems = oCalendar.Items
    Dim oItemsInDateRange       As Outlook.Items
    Dim oAppt                   As Outlook.AppointmentItem
    Dim strRestriction          As String
    Dim EndDate                 As Date

    EndDate = DateAdd("d", 1, StartDate)
    strRestriction = "[Start] >= '" & Format$(StartDate, "mm/dd/yyyy hh:mm AMPM") & _
                     "' AND [End] <= '" & Format$(EndDate, "mm/dd/yyyy hh:mm AMPM") & "'"

    oItems.IncludeRecurrences = True
    oItems.Sort "[Start]"
    Set oItemsInDateRange = oItems.Restrict(strRestriction)

    For Each oAppt In oItemsInDateRange
        If oAppt.Subject = MeetingSubject And oAppt.Duration = Duration Then
            MeetingExists = True
            Exit Function
        End If
    Next

End Function

Upvotes: 1

Related Questions