Delete Outlook Meeting Appointments - Searching for Specific String in Body

[JoeyMang83]

Hi All,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
My VBA skills are limited, and I’ve looked far and wide to get some code to emulate to do the following:<o></o>
<o></o>
1. Search the Outlook calendar (for whichever user clicks the Macro button).<o></o>
<o></o>
2. Search [or find] in the “notes” or “body” of a calendar meeting appointment for a particular string (located in cell H2 of the Active.Sheet). If it finds that string in any calendar entry body it will delete any such calendar meetings and send a response to any recipients that were part of that meeting. There may be up to 50 meetings related to this string, so all would need to be deleted from the calendar with auto response being sent to all recipients that it is being cancelled.<o></o>
<o></o>
Sounds pretty simple, but cannot find any solid code for the life of me.<o></o>
<o></o>
I found this thread this web site doing a search, but it doesn’t quite do what I need…
<o></o>
http://www.mrexcel.com/forum/showthread.php?t=564254&highlight=delete+outlook+calendar<o></o>
<o></o>
I also found some code here, but this is not it, and does not do what I’d like it to either.<o></o>
<o></o>

Dim olApp As Outlook.Application<o:p></o:p>
  Dim objAppointment As Outlook.AppointmentItem<o:p></o:p>
  Dim objAppointments As Outlook.MAPIFolder<o:p></o:p>
  Dim objNameSpace As Outlook.NameSpace<o:p></o:p>
  Dim objProperty As Outlook.UserProperty<o:p></o:p>
  Dim OutlookStartTime, OutlookEndTime As Date<o:p></o:p>
  Dim sFilter As Variant<o:p></o:p>
  <o:p></o:p>
  OutlookStartTime = CDate(AP_Date & " " & AP_Start_Time)<o:p></o:p>
  OutlookEndTime = CDate(AP_Date & " " & AP_End_Time)<o:p></o:p>
  <o:p></o:p>
  Set olApp = CreateObject("Outlook.Application")<o:p></o:p>
  Set objNameSpace = olApp.GetNamespace("MAPI")<o:p></o:p>
  Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)<o:p></o:p>
  <o:p></o:p>
  sFilter = "[Start] = '" & Format(OutlookStartTime, "ddddd h:nn AMPM") & _<o:p></o:p>
    "' And [End] = '" & Format(OutlookEndTime, "ddddd h:nn AMPM") & "' " & _<o:p></o:p>
    " And [Subject] = '" & Me.AP_With_Whom & " - " & Me.AP_Type & "'"<o:p></o:p>
  <o:p></o:p>
  Set objAppointment = objAppointments.items.Find(sFilter)<o:p></o:p>
  <o:p></o:p>
  If Not TypeName(objAppointment) = "Nothing" Then<o:p></o:p>
    objAppointment.Delete<o:p></o:p>
  End If<o:p></o:p>
  <o:p></o:p>
  Set objAppointment = Nothing<o:p></o:p>
  Set objAppointments = Nothing<o:p></o:p>
<o:p></o:p>
End Sub<o:p></o:p>

<o></o>
Thank you in advance for your help.<o></o>

 

[JoeyMang83]

Any help here would be greatly appreciated. I just need to search the user's outlook database for a particular string in the body of all calendar appointments and if that string is found it will delete any such appointments. That string would be a value in L5. Thank you.

 

[JP2112]

After getting a reference to the local Calendar folder, you should use the Restrict method on the objAppointments Object to limit the number of appointments. Ex:

Sub DeleteMatchingAppts()
 
Dim olApp As Object ' Outlook.Application
Dim startDate As String
Dim endDate As String
Dim appts As Object ' Outlook.Items
Dim dateFilter As String
Dim appt As Object ' Outlook.AppointmentItem
Dim i As Long
Dim stringToSearchFor As String
 
Const olFolderCalendar = 9
 
' edit to specify start and end date to be searched
startDate = "12/1/2011"
endDate = "12/31/2012"
 
Set olApp = CreateObject("Outlook.Application")
stringToSearchFor = ActiveSheet.Range("H2").Value
 
Set appts = olApp.Session.GetDefaultFolder(olFolderCalendar).Items
 
' filter for December appointments only
dateFilter = "[Start] >= " & Quote(startDate & " 12:00 AM") & _
" AND [End] <= " & Quote(endDate & " 11:59 PM")
Set appts = appts.Restrict(dateFilter)
 
' check each appt body for matching string
For i = appts.Count To 1 Step -1
  Set appt = appts.Item(i)
  If Instr(appt.Body, stringToSearchFor) > 0 Then ' found
    appt.Delete
  End If
Next appt
 
End Sub
 
Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
 Quote = Chr(34) & MyText & Chr(34)
End Function

This is air code so please compile it first.

 

[rex759]

Great code! I altered it slightly to fit my needs. However, I’m getting some strange behaviors that have me perplexed. If I have multiple appointments for one day with the same search string, it doesn’t delete all of them, some of the time. It depends on the combination of strings in the date.
For example;

If Feb 16 has:
• Primary, secondary and 1 call, when I run the macro it removes primary and secondary (leaves call)
• Primary, secondary and 2 calls - removes primary and secondary (leaves 2 calls)
• Primary, 2 calls, - removes primary (leaves 2 calls)
• Primary, 3 calls – removes primary and 1 call (leaves 2 call)
• Primary, 4 calls – removes primary and 2 calls (leaves 2 calls)
• Primary, 5 calls – removes everything
• Primary, 6 calls – removes everything

If there’s any appointments left after running the macro the first time, if I hit the macro a second time, it removes the rest of the appointments.

Any help is appreciated.

Sub DeleteMatchingAppts()
Dim olApp As Object ' Outlook.Application
Dim startDate As String
Dim endDate As String
Dim appts As Object ' Outlook.Items
Dim dateFilter As String
Dim appt As Object ' Outlook.AppointmentItem
Dim i As Long
Dim stringToSearchFor As String

Const olFolderCalendar = 9

'Grab the date in column B, this is to determine the month range
lastrow = Worksheets("sheet1").Range("b65536").End(xlUp).Row
e = "$b$" & lastrow
mylastday = Worksheets("sheet1").Range(e)

'Determines the First and last days of the month
startDate = DateSerial(Year(mylastday), Month(mylastday), 1)
endDate = DateSerial(Year(mylastday), Month(mylastday) + 1, 0)

Set olApp = CreateObject("Outlook.Application")
Set appts = olApp.Session.GetDefaultFolder(olFolderCalendar).Items

' filter for appointments by subject and specified dates
dateFilter = "[Start] >= " & Quote(startDate & " 12:00 AM") & _
" AND [End] <= " & Quote(endDate & " 11:59 PM")

Set appts = appts.Restrict(dateFilter)

For c = 1 To 3
Select Case c
Case 1
stringToSearchFor = "Primary"
Case 2
stringToSearchFor = "Secondary"
Case 3
stringToSearchFor = "Call"
End Select

' check each appt subject for matching string
For i = appts.count To 1 Step -1
Set appt = appts.Item(i)
If InStr(appt.Subject, stringToSearchFor) > 0 Then ' found
appt.Delete
End If
Next
Next c
End Sub

Private Function Quote(MyText)
Quote = Chr(34) & MyText & Chr(34)
End Function

 

[rex759]

Solved! Move my case function and it worked just fine.