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, "
- Type 2. Shared appointments. "
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 "
However, it does not seem to pick-up on existing type 2 appointments "
I cannot figure out why "
Here is a google drive link with a sample workbook for this system I currently have set up.
Renewal Dates Sample.xlsm
Yoseph.
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 FunctionI 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.
