finding specific appointments in agenda through excel vba - vba

Question

I have an excel file in which i register action of employees.
This is the following design:
ID Datum Type Typedatail Metadata Regdata hours
3767 01/04/2018 SN VM 64 05/01/2018 4
3767 01/04/2018 SN NM 65 05/01/2018 4
3767 03/04/2018 SN VM 66 05/01/2018 4
3767 03/04/2018 SN NM 67 05/01/2018 4
3767 04/04/2018 SN VM 68 05/01/2018 4
3767 04/04/2018 SN NM 69 05/01/2018 4
3767 07/04/2018 CA 70 05/01/2018 8
3767 08/04/2018 CA 71 05/01/2018 8
3767 09/04/2018 CA 72 05/01/2018 8
3683 12/01/2018 OU- 73 05/01/2018 -8
I need to put them into a calender also to distribute this knowledge.
!(https://ibb.co/hQmOxR)
But at times i need to edit those. (change or delete those)
i have found the following as a base
Search Appointments in excel with VBA
This finds them eventually but this runs through ALL the appointments, which is unneeded as i know on which date the appointment is set.
Therefore i want to restrict the range but i make a fault with it, that i can not figure out.
Base find appointment
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) As Boolean
Const olAppointment = 26 ' <== Added this line and your code worked.
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oMeetingoApptItem As Object
Dim oObject As Object
Dim strRestriction As String 'opmaak zoekbeperking
On Error Resume Next ' No appointment was found since you have this line and olAppointmnet wasn't defined.
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar) 'oNameSpace.Session.GetDefaultFolder(9).Folders(olFolderCalendar)
CheckAppointment = False
For Each oObject In oFolder.Items
'MsgBox oObject
If (oObject.Class = olAppointment) Then ' <== This is why you need to define it first
Set oApptItem = oObject
If oApptItem.Start = argCheckDate And InStr(oApptItem.Body, argTikNummer) Then
MsgBox oApptItem.Body
CheckAppointment = True
Exit For ' <== Added this exit for loop to improve performance
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function
Public Sub Driver()
Dim dtCheck As Date
Dim intTikNummer As Integer
Dim sbCheck As String
Sheets("blad1").Select
Dim i As Long
i = 2
Do Until Trim(Cells(i, 1).Value) = "" 'voorlopig test omgeving. Moet worden omgevormd tot een single entry test
dtCheck = Cells(i, 2) '+ TimeValue("09:00:00")
intTikNummer = Cells(i, 1)
If CheckAppointment(dtCheck, intTikNummer) Then
MsgBox "Appointment found", vbOKOnly + vbInformation 'dummy uitkomst verslag. Moet worden vervangen door een opdracht
Else
MsgBox "Appointment not found", vbOKOnly + vbExclamation 'dummy uitkomst verslag. Moet worden vervangen door een opdracht
End If
i = i + 1
Loop
End Sub
`
Base restriction example (outlook)
Sub FindAppts()
Dim myStart As Date
Dim myEnd As Date
Dim oCalendar As Outlook.folder
Dim oItems As Outlook.items
Dim oItemsInDateRange As Outlook.items
Dim oFinalItems As Outlook.items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String
myStart = Date
myEnd = DateAdd("d", 30, myStart)
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
'Construct filter for the next 30-day date range
strRestriction = "[Start] >= '" &; _
Format$(myStart, "mm/dd/yyyy hh:mm AMPM") _
&; "' AND [End] <= '" &; _
Format$(myEnd, "mm/dd/yyyy hh:mm AMPM") &; "'"
'Check the restriction string
Debug.Print strRestriction
Set oCalendar = Application.session.GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.items
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
'Restrict the Items collection for the 30-day date range
Set oItemsInDateRange = oItems.Restrict(strRestriction)
'Construct filter for Subject containing 'team'
Const PropTag As String = "http://schemas.microsoft.com/mapi/proptag/"
strRestriction = "#SQL=" &; Chr(34) &; PropTag _
&; "0x0037001E" &; Chr(34) &; " like '%team%'"
'Restrict the last set of filtered items for the subject
Set oFinalItems = oItemsInDateRange.Restrict(strRestriction)
'Sort and Debug.Print final results
oFinalItems.Sort "[Start]"
For Each oAppt In oFinalItems
Debug.Print oAppt.Start, oAppt.Subject
Next
End Sub
`
I came to the following result (through example)
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) As Boolean
Const olAppointment = 26 ' <== Added this line and your code worked.
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oFolderA As Object
Dim oFolderB As Object
Dim oMeetingoApptItem As Object
Dim oObject As Object
Dim myStart, myEnd As Date
Dim strRestriction As String 'opmaak zoekbeperking
'Construct filter for day date range
myStart = Format(argCheckDate, "dd/mm/yyyy") 'argcheckdate
myEnd = DateAdd("d", 1, myStart)
myEnd = Format(myEnd, "dd/mm/yyyy") 'Argcheckdate
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
strRestriction = "[Start] = '" & myStart & "' AND [End] = '" & myEnd & "'"
On Error Resume Next ' No appointment was found since you have this line and olAppointmnet wasn't defined.
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar) 'oNameSpace.Session.GetDefaultFolder(9).Folders(olFolderCalendar)
CheckAppointment = False
'Restrict the Items collection for the 30-day date range
Set oFolderA = oFolder.Restrict(strRestriction)
For Each oObject In oFolderA.Items
MsgBox oObject & " : " & oObject.Start & " : " & myStart & " - " & myEnd
If (oObject.Class = olAppointment) Then ' <== This is why you need to define it first
Set oApptItem = oObject
If oApptItem.Start = argCheckDate And InStr(oApptItem.Body, argTikNummer) Then
MsgBox oApptItem.Body
CheckAppointment = True
Exit For ' <== Added this exit for loop to improve performance
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oFolderA = Nothing
Set oFolderB = Nothing
Set oObject = Nothing
End Function
I end up with an empty oApptItem yet If oApptItem.Start = argCheckDate And InStr(oApptItem.Body, argTikNummer) trigger true despite the appointments not being in the list.
The above code is meant as a base to be used to edit or delete an appointment.

Answer 1

Filtering a calendar is tricky and this is compounded by not turning off On Error Resume Next.
Option Explicit
Private Sub CheckAppointment_test()
' Appointment date
Dim argCheckDate As String
argCheckDate = "2018-01-05"
' Text in body of appointment
Dim argTikNummer As Long
argTikNummer = 3767
Dim result As Boolean
MsgBox CheckAppointment(argCheckDate, argTikNummer) & vbCr & " Done."
End Sub
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) As Boolean
' Not required as Outlook must be referenced
' to use olFolderCalendar later
'Const olAppointment = 26
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oFolderA As Object
Dim oObject As Object
Dim myStart, myEnd As Date
Dim strRestriction As String
'Construct filter for day date range
'myStart = Format(argCheckDate, "dd/mm/yyyy") 'argcheckdate
myStart = Format(argCheckDate, "yyyy-mm-dd") 'argcheckdate
myEnd = DateAdd("d", 1, myStart)
'myEnd = Format(myEnd, "dd/mm/yyyy") 'Argcheckdate
myEnd = Format(myEnd, "yyyy-mm-dd") 'Argcheckdate
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
'strRestriction = "[Start] = '" & myStart & "' AND [End] = '" & myEnd & "'"
strRestriction = "[Start] <= '" & myEnd & "' AND [End] >= '" & myStart & "'"
Debug.Print strRestriction
' Misuse causes insurmountable problems as errors are hidden
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
' Mandatory with On Error Resume Next to stop bypassing errors
On Error GoTo 0
' Handle error bypassed above, if any
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
CheckAppointment = False
' *******
Dim oFolderItems As Object
Set oFolderItems = oFolder.items
' Strange behaviour if this is not used
oFolderItems.IncludeRecurrences = True
oFolderItems.Sort "[Start]"
' *******
'Restrict the Items collection for the specified date range
Set oFolderA = oFolderItems.Restrict(strRestriction)
'For Each oObject In oFolderA.items
For Each oObject In oFolderA
Debug.Print oObject.Subject & " : " & oObject.Start
If (oObject.Class = olAppointment) Then
Set oApptItem = oObject
Debug.Print "oApptItem.Start: " & oApptItem.Start
Debug.Print "Formatted oApptItem.Start: " & Format(oApptItem.Start, "yyyy-mm-dd")
Debug.Print "argCheckDate: " & argCheckDate
' Not true unless oApptItem.Start is formatted to match format of argCheckDate
' Should not be necessary if the filter is working correctly
'If oApptItem.Start = argCheckDate Then
Debug.Print InStr(oApptItem.body, argTikNummer)
If InStr(oApptItem.body, argTikNummer) Then
MsgBox oApptItem.Subject & vbCr & oApptItem.body
CheckAppointment = True
' Do not exit if there can be multiple appointments
'Exit For
End If
'End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oFolderA = Nothing
Set oObject = Nothing
End Function