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.
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

CSmith

Well-known Member
Joined
Jan 13, 2020
Messages
686
Office Version
  1. 365
  2. 2010
  3. 2007
Platform
  1. Windows
  2. Mobile
  3. Web
*EDIT* misread code... Checking...
 

CSmith

Well-known Member
Joined
Jan 13, 2020
Messages
686
Office Version
  1. 365
  2. 2010
  3. 2007
Platform
  1. Windows
  2. Mobile
  3. Web
Did you debug and verify that it finds meetings already matching?
 

Yosepht

New Member
Joined
Nov 19, 2019
Messages
33
From what I could deduce, it returns a 0 value when searching for an existing meeting
 

Yosepht

New Member
Joined
Nov 19, 2019
Messages
33

ADVERTISEMENT

*Update*
I've changed the column that the start date is referenced from in Public Sub CreateOutlookMeetings(). It was referencing from column 3 which is not the correct date. This has not fixed the problem but should prevent any weird problems occurring in the future.
VBA Code:
  i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 4).Value


When running the debugger, I noticed that Private Function Find_Meeting skips a step that is highlighted during the same operation in Private Function Find_Appointment
VBA Code:
If StrComp(olCalendarItems(i).Body, bodyText & " " & vbCrLf, vbTextCompare) = 0 Then Set Find_Meeting = olCalendarItems(i)

Then Set Find_Meeting = olCalendarItems(i) does not highlight at all during debug, whereas Then Set Find_Appointment = olCalendarItems(i) does highlight.

Lastly, I feel that checking the appointment body text is obsolete because I only need a positive match for the appointment name and date which already exists in my calendar to void a new meeting being created. I have no idea how to do this.
 

CSmith

Well-known Member
Joined
Jan 13, 2020
Messages
686
Office Version
  1. 365
  2. 2010
  3. 2007
Platform
  1. Windows
  2. Mobile
  3. Web
Well check the object structure with the debugger and determine what properties olCalendarItems(i) has and you should find what fields/cell columns you need to to compare.
 

Yosepht

New Member
Joined
Nov 19, 2019
Messages
33

ADVERTISEMENT

I’m completely inexperienced with VBA. Unfortunately, I have no idea how to find the correct fields in the debugger, it’s complete gibberish to me and there are 20+ drop-down items all with more sub categories. I don’t know where to begin to find the correct items.
 

CSmith

Well-known Member
Joined
Jan 13, 2020
Messages
686
Office Version
  1. 365
  2. 2010
  3. 2007
Platform
  1. Windows
  2. Mobile
  3. Web
set breakpoint at that line
look in the locals window for the array
open array and look at the property/value pairs
 

Yosepht

New Member
Joined
Nov 19, 2019
Messages
33
I think I may have discovered a problem. The olcalendarItems/parent/items only lists 256 items. Is this some sort of limit? (256 bytes?) If so, how would I adjust the Vb code to search dates only in the future. For example, up to 365 days ahead?
 

CSmith

Well-known Member
Joined
Jan 13, 2020
Messages
686
Office Version
  1. 365
  2. 2010
  3. 2007
Platform
  1. Windows
  2. Mobile
  3. Web
The array count should be based on the number of items matching the filter set.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,479
Messages
5,636,573
Members
416,925
Latest member
malamutus

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
Top