VBA / Macro: Book Excel dates to Outlook Appointment.

Yosepht

New Member
Joined
Nov 19, 2019
Messages
33
Hi Everyone,

I'm in the final stages of getting this vb code finished to book appointments to my default outlook calendar in outlook 365 (desktop version). There are two calendar appointment types:

- Type 1. Personal Appointments, "CreateOutlookAppointments()"
- Type 2. Shared appointments. "CreateOutlookMeetings()"

The only difference is that 2. requires an attendee and is set as OlMeeting. Both appointment types are created as intended and I have set the code to ignore past dates when it loops through.

I also need the code to ignore existing appointments in my default outlook calendar which it currently does without a problem on all type 1 appointments "CreateOutlookAppointments()".

However, it does not seem to pick-up on existing type 2 appointments "CreateOutlookMeetings()" within the code below:

VBA Code:
Public Sub CreateOutlookAppointments()
   Sheets("sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 3).Value
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        ' check whether the start date is today or later, and whether recipients exist
        If startDate >= Date And Len(theRecipients) = 0 Then
            Set olAppt = Find_Appointment(CalFolder, Cells(i, 1) & Cells(i, 2), Cells(i, 4), Cells(i, 6))
            If olAppt Is Nothing Then
                Set olAppt = CalFolder.Items.Add(olAppointmentItem)
                With olAppt
                'Define calendar item properties
                    .subject = Cells(i, 1) & Cells(i, 2)
                    .Start = Cells(i, 4)
                    .Categories = Cells(i, 5)
                    .Body = Cells(i, 6)
                    .AllDayEvent = True
                    .BusyStatus = olFree
                    .ReminderMinutesBeforeStart = 2880
                    .ReminderSet = True
                    .Display
                End With
            End If
        End If
        i = i + 1
    Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

Private Function Find_Appointment(calendarFolder As Outlook.MAPIFolder, subject As String, startDateTime As Date, bodyText As String) As Outlook.AppointmentItem

    Dim filter As String
    Dim i As Long
    Dim olCalendarItems As Outlook.Items
  
    Set Find_Appointment = Nothing
  
    'Get calendar items with the specified subject and start time
      
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd Hh:Nn") & "'"
    Set olCalendarItems = calendarFolder.Items.Restrict(filter)
  
    'See if any calendar items match the specified body text
  
    If Not olCalendarItems Is Nothing Then
        i = 0
        While i < olCalendarItems.Count And Find_Appointment Is Nothing
            i = i + 1
            If StrComp(olCalendarItems(i).Body, bodyText & " " & vbCrLf, vbTextCompare) = 0 Then Set Find_Appointment = olCalendarItems(i)
        Wend
    End If
  
End Function

Public Sub CreateOutlookMeetings()
   Sheets("sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 3).Value
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        ' check whether the start date is today or later, and whether recipients exist
        If startDate >= Date And Len(theRecipients) > 0 Then
        Set olAppt = Find_Meeting(CalFolder, Cells(i, 1) & Cells(i, 2), Cells(i, 4), Cells(i, 6))
            If olAppt Is Nothing Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)
            With olAppt
               .MeetingStatus = olMeeting
                'Define calendar item properties
                    .subject = Cells(i, 1) + Cells(i, 2)
                    .Start = Cells(i, 4)
                    .Categories = Cells(i, 5)
                    .Body = Cells(i, 6)
                    .AllDayEvent = True
                    .BusyStatus = olFree
                    .ReminderMinutesBeforeStart = 2880
                    .ReminderSet = True
                ' get the recipients
                Dim RequiredAttendee As Outlook.Recipient
                Set RequiredAttendee = .Recipients.Add(theRecipients)
                    RequiredAttendee.Type = olRequired
                    .Display
                End With
            End If
        End If
        i = i + 1
    Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

Private Function Find_Meeting(calendarFolder As Outlook.MAPIFolder, subject As String, startDateTime As Date, bodyText As String) As Outlook.AppointmentItem

    Dim filter As String
    Dim i As Long
    Dim olCalendarItems As Outlook.Items
  
    Set Find_Meeting = Nothing
  
    'Get calendar items with the specified subject and start time
      
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd Hh:Nn") & "'"
    Set olCalendarItems = calendarFolder.Items.Restrict(filter)
  
   'See if any calendar items match the specified body text
  
    If Not olCalendarItems Is Nothing Then
        i = 0
        While i < olCalendarItems.Count And Find_Meeting Is Nothing
            i = i + 1
            If StrComp(olCalendarItems(i).Body, bodyText & " " & vbCrLf, vbTextCompare) = 0 Then Set Find_Meeting = olCalendarItems(i)
    
        Wend
    End If
  
End Function

I cannot figure out why "CreateOutlookMeetings()" is not acknowledging existing type 2 appointments in my outlook calendar. Please can someone help me adjust the code to pick up on existing type 2 appointments?

Here is a google drive link with a sample workbook for this system I currently have set up.

Renewal Dates Sample.xlsm

Yoseph.
 
I have no idea what that means, sorry. The only items I can find are under OlCalendarItems>parent>items are 256 items that are all from the Microsoft bookings app in for outlook 365.

The “count” however, displays “436”. I was expecting to be able to see all of the items that the function has discovered because the function successfully finds and excludes existing outlook appointments for The “find_appointment” function.

I’m simply stabbing in the dark trying to find a solution as I don’t have a clue what I’m doing or looking for.
 
Upvote 0

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
olcalendar is an array and you should not be looking at the parent
 
Upvote 0
Okay, what should I look at? In olCalendarItems there are the following options:
Application
Class
Count
IncludeRecurrences
Parent
RawTable
Session
Item 1

where should I be looking within this list?
 
Upvote 0
VBA Code:
Private Function Find_Meeting(calendarFolder As Outlook.MAPIFolder, subject As String, startDateTime As Date, bodyText As String) As Outlook.AppointmentItem

    Dim filter As String
    Dim i As Long
    Dim olCalendarItems As Outlook.Items
   
    Set Find_Meeting = Nothing
   
    'Get calendar items with the specified subject and start time
       
    filter = "[Subject] = " & subject & "' and [Start] = '" & Format(startDateTime, "dd/mm/yyyy hh:nn") & "'"
    Set olCalendarItems = calendarFolder.Items.Restrict(filter)
   
   'See if any calendar items match the specified body text
   
    If Not olCalendarItems Is Nothing Then
        i = 0
        While i < olCalendarItems.Count And Find_Meeting Is Nothing
            i = i + 1
            If StrComp(olCalendarItems(i).Body, bodyText & " " & vbCrLf, vbTextCompare) = 0 Then Set Find_Meeting = olCalendarItems(i)
        Wend
    End If
   
End Function

With the breakpoint set to If Not olCalendarItems Is Nothing Then the Count in olcalendaritems = 0. Does this mean the function is not finding a match?
 
Upvote 0
Was there anything under item1?
 
Upvote 0
I think i was looking in a sub menu when i mentioned Item 1 previously. here is a screen grab of the window
Annotation 2020-01-22 182145.png
 
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,176
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top