Delete Outlook Appointments

[DMT Dave]

Hi Guy's i have had a search on Google to see if there is an adaption i can do



Does any one or has anyone used VBA to remove all outlook appointments prior to todays date ?

I have this to add an appointment but it would be good to clear historic appointments prior todays date

Set olobj = CreateObject("Outlook.Application")    Set oloappt = olobj.CreateItem(olAppointmentItem)


    With oloappt
        If intDays = 1 Then
            .Start = Nz(apptDate, "") & " " & Nz(apptStartTime, "")
        End If
        
        If intDays > 1 Then
            .Start = Nz(dtStartDate, "")
            .End = Nz(dtEndDate, "")
        End If
        
        If strCC <> "" Then
            .RequiredAttendees = strCC
        End If
            
        .subject = strSubj & " " & "Appointment " & strName & " " & apptDate & " " & apptStartTime
        .ReminderMinutesBeforeStart = 10080
        .ReminderSet = True
        .Location = "DMT Ltd"
        .Body = Replace(strBody, "|", vbCrLf & vbCrLf)
        .Save
        .Close (olSave)
    End With


     If MsgBox("Your New Appointment Is Now Saved In Outlook Calendar", vbOKOnly, "APPOINTMENT SAVED") = vbOK Then
        Set ol = CreateObject("Outlook.Application")
        Set olNS = ol.GetNamespace("MAPI")
        Set objCalendar = olNS.GetDefaultFolder(olFolderCalendar)
        objCalendar.Display
        Set olExp = objCalendar.GetExplorer
        Set viw = olExp.CurrentView
        viw.GoToDate Date
    End If

[Gicu]

Some links for you:
https://social.msdn.microsoft.com/Fo...orum=accessdev
From this one I cleaned up Ruddles post, I assume you still want to filter by subject like he does, you would just need to add criteria using the AppointmentItem.Start property to get the ones prior to today:
https://www.mrexcel.com/board/thread...th-vba.564254/

Option ExplicitOption Compare Text
 
Public Sub Driver()
 Call DeleteAppointments("wibble")
End Sub
 
Public Sub DeleteAppointments(ByVal argSubject As String)
 
 Dim oApp As Outlook.Application
 Dim oNameSpace As Outlook.Namespace
 Dim oApptItem As Outlook.AppointmentItem
 Dim oFolder As Outlook.MAPIFolder
 Dim oMeetingoApptItem As Outlook.MeetingItem
 Dim oObject As Object
 Dim iUserReply As VbMsgBoxResult
 Dim sErrorMessage As String
 
 On Error Resume Next
 ' check if Outlook is running
 Set oApp = GetObject("Outlook.Application")
 If Err <> 0 Then
   'if not running, start it
   Set oApp = CreateObject("Outlook.Application")
 End If
 
 On Error GoTo Err_Handler
 Set oNameSpace = oApp.GetNamespace("MAPI")
 Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
 
 For Each oObject In oFolder.Items
   If oObject.Class = olAppointment Then
     Set oApptItem = oObject
     If InStr(oApptItem.Subject, argSubject) > 0 Then
       iUserReply = MsgBox("Appointment found:-" & vbCrLf & vbCrLf _
            & Space(4) & "Date/time: " & Format(oApptItem.Start, "dd/mm/yyyy hh:nn") _
            & " (" & oApptItem.Duration & "mins)" & Space(10) & vbCrLf _
            & Space(4) & "Subject: " & oApptItem.Subject & Space(10) & vbCrLf _
            & Space(4) & "Location: " & oApptItem.Location & Space(10) & vbCrLf & vbCrLf _
            & "Delete this appointment?", vbYesNo + vbQuestion + vbDefaultButton2, "Delete Appointment?")
       If iUserReply = vbYes Then oApptItem.Delete
     End If
   End If
 Next oObject
 
 Set oApp = Nothing
 Set oNameSpace = Nothing
 Set oApptItem = Nothing
 Set oFolder = Nothing
 Set oObject = Nothing
 
 Exit Sub
 
Err_Handler:
 sErrorMessage = Err.Number & " " & Err.Description
 
End Sub

Cheers,

[DMT Dave]

Cheers Vlad, i will do some work on it

[DMT Dave]

Hi Vlad, thank you, i have got this so far but i know all too well about deleting something i shouldn't so i am reluctant to press yes on the delete message

So because of my fear, i have shared the calendar back to my email address, if for some reason my paranoia telling me i may end up deleting all appointments, can i easily transfer the one i have emailed back to me as my standard outlook calendar ?

This has all the correct message that is going to remove all appointments before today but dare i press yes when prompted

 Dim olApp As Outlook.Application  Dim objAppointment As Outlook.AppointmentItem
  Dim objAppointments As Outlook.MAPIFolder
  Dim objNameSpace As Outlook.Namespace
  Dim objProperty As Outlook.UserProperty
  Dim sFilter As Variant
DIm dtStart as Date, dtEnd as Date
    dtEnd = Date
    dtStart = DateAdd("d", -365, dtEnd)
  
  Set olApp = CreateObject("Outlook.Application")
  Set objNameSpace = olApp.GetNamespace("MAPI")
  Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
  
  sFilter = "[Start] = '" & Format(dtStart, "ddddd h:nn AMPM") & _
    "' And [End] = '" & Format(dtEnd, "ddddd h:nn AMPM") & "'"


  Set objAppointment = objAppointments.Items.Find(sFilter)
  
  Debug.Print sFilter
  
  If MsgBox("Delete All Appointments Between:" & vbNewLine & vbNewLine & _
  sFilter, vbQuestion + vbYesNo, "DELETE APPOINTMENTS") = vbNo Then
    Exit Sub
    Else
  If Not TypeName(objAppointment) = "Nothing" Then
    objAppointment.Delete
  End If
  End If
  
  Set objAppointment = Nothing
  Set objAppointments = Nothing

[Welshgasman]

Again, you can always WALK through your code one line at a time.
Plus use Debug.Print and comment out the Delete statement until you get it right.?

[DMT Dave]

WGM, yes i can see the dates in the immediate window are correct to today - 365 days so the result is telling me that in IMM window!

Do you mean put the brown block on the line then run the debug.print just before that point ?

[Welshgasman]

Put the breakpoint(s) where ever you feel it is needed. Comment out the delete until you are sure it is working correctly, then uncomment the delete.
You should get a list of the data you are printing to the immediate window, and be able to check it out, before doing the delete.

[DMT Dave]

trying it now, i just done debug.print on sFilter to check dates

[DMT Dave]

So if i am reading this correct, this will stop at deleting appointments but show everything before it in the IMM window ?

[DMT Dave]

sorry just picked up comment out the delete

[Welshgasman]

Yes, but then it would delete the appointment.
The whole point of my chipping in to is to say 'make sure it is all correct before even attempting a delete'. The same way you would use a select query to make sure the data is correct, before changing it to a delete query.
I would comment that out and put the display of objappointment. whatever you want to see to confirm that is what you want to delete. Concatenate the properties into one or two debug.print statements.

[Gicu]

Dave, shouldn't dtEnd be =Date-1?

Cheers,