A Slipstick.com visitor asked how to assign a category to his appointments automatically, as soon as they are over.
You can do this using a macro with a trigger, such as the meetings own reminder or the next appointment reminder, that will kick off the macro. The other option is to run a macro manually, such as at the end of the day.
If you don't assign color categories to any appointments, you can use a custom view to apply automatic formatting colors to old appointments. Category colors take precedence, so this method only works on non-categorized appointments and events.
This macro is triggered by an appointment reminder and checks all appointments with End times between Now and 3 days ago. If you don't restrict it to recent events, the macro will check every appointment, which could take several minutes. (I used 3 days to cover days when there are no appointments.)
To keep any existing categories, use Appt.Categories = "Completed;" & Appt.Categories or Appt.Categories = "Completed" to erase categories and replace them with the Completed category.
To use the Appointment start date, use Appt.Start < Now().
Set the category when a reminder fires
This macro code goes into ThisOutlookSession. When an appointment reminder fires, it runs. To run it when any reminder fires, remove the If... End If code block.
Private Sub Application_Reminder(ByVal Item As Object)
If Item.MessageClass <> "IPM.Appointment" Then
Exit Sub
End If
Dim Appt As Object
Set Items = Session.GetDefaultFolder(olFolderCalendar).Items
For Each Appt In Items
On Error Resume Next
If Appt.End < Now() And Appt.End> Now() - 3 Then
Appt.Categories = "Completed;" & Appt.Categories
Appt.ReminderSet = False
Appt.Save
End If
Next
Set Appt = Nothing
End Sub
Set the category using a macro
This macro can be placed in a module or in ThisOutlookSession and assigned to a button on the ribbon or QAT for easy access.
If you want to make the change at the end of the day, you can run this macro to change all appointments with a start time before now.
Public Sub AddCategory()
Dim Appt As Object
Set Items = Session.GetDefaultFolder(olFolderCalendar).Items
For Each Appt In Items
On Error Resume Next
If Appt.End < Now() Then
With Appt
.Categories = "Completed"
.ReminderSet = False
.Save
End with
End If
Next
Set Appt = Nothing
End Sub
FWIW, I think I have found my own solution. The issue was *recurring* appointments. (Some of the items were, some were not.) In case it helps anyone, here is the code that finally did the trick: Private Sub FixBDDates() Dim myOLApp As Outlook.Application Dim myNamespace As NameSpace Dim olCalFolder As Outlook.Items Dim olCalEs As Outlook.Items Dim olCalE As Outlook.AppointmentItem Dim olCalERP As RecurrencePattern Dim dNewStartTime As Date Dim dNewStopTime As Date Set myOLApp = CreateObject("Outlook.Application") Set myNamespace = myOLApp.GetNamespace("MAPI") Set olCalFolder = myNamespace.GetDefaultFolder(olFolderCalendar).Items Set olCalEs = olCalFolder olCalEs.Sort "[Subject]", False For Each olCalE In olCalEs If olCalE.Class = olAppointment Then If (Right(olCalE.Subject, 11) = "'s Birthday") Or (Right(olCalE.Subject, 14) = "'s Anniversary") Then dNewStartTime = DateAdd("h", 8, DateValue(olCalE.Start)) dNewStopTime = DateAdd("n", 30, dNewStartTime) If olCalE.IsRecurring Then With olCalE Set olCalERP = olCalE.GetRecurrencePattern With olCalERP .StartTime = dNewStartTime .EndTime = dNewStopTime .Duration = 30 End With .Categories = "Birthday or Anniversary" .ReminderMinutesBeforeStart = 5760 .BusyStatus = 0 .Save End With Else With olCalE .Start = dNewStartTime .End = dNewStopTime .Duration = 30 .Categories = "Birthday or Anniversary" .ReminderMinutesBeforeStart = 5760 .AllDayEvent = False .BusyStatus = 0 .Save End With End If End If End If Next End Sub
I've reviewed multiple threads about updating calendar items, and I have a VBA SUB that looks like it should work just fine; it's pretty straightforward. My calendar syncs with an application that turned all of my birthday and anniversary items into all-day events. When I turned that off (with an earlier version of this code), they were all set for 0 minutes at midnight; I'm trying to set them all for 30 minutes at 8am. However, certain key properties - Start, and End in particular - return an error stating that "The object does not support this method" (emphasis mine). There is no start method, so I'm confused. My code worked just fine, though, to change the category. Your examples here don't show me anything that would explain this. Sub FixBDDates() Dim myOLApp As Outlook.Application Dim myNamespace As NameSpace Dim olCalFolder As Outlook.Items Dim olCalEs As Outlook.Items Dim olCalE As Outlook.AppointmentItem Dim dNewStartTime As Date Dim dNewStopTime As Date Set myOLApp = CreateObject("Outlook.Application") Set myNamespace = myOLApp.GetNamespace("MAPI") Set olCalFolder = myNamespace.GetDefaultFolder(olFolderCalendar).Items Set olCalEs = olCalFolder olCalEs.Sort "[Subject]", False For Each olCalE In olCalEs If olCalE.Class = olAppointment Then If (Right(olCalE.Subject, 11) = "'s Birthday") Or (Right(olCalE.Subject, 14) = "'s Anniversary")… Read more »
This thread comes close to solving my problem, but not quite: I would like a macro that automatically assigns categories to appointments (that I create, not invitations) on the basis of words in the subject. Any suggestions?
I have found one VBA script that does this (https://www.experts-exchange.com/questions/25072154/How-to-automatically-assign-categories-to-calendar-appointments-in-Outlook-based-on-simple-rules-on-the-subject.html#answer26411907). However, the opening line "Dim WithEvents olkCalendar As Outlook.Items" produces an error. (It is shown in read, and the Macro does not seem to run).
I would be very grateful for any suggestions!
Is the macro in ThisOutlookSession? Automatic macros needs to be put there.
Let me start by saying you've been amazingly helpful!
That said, I'm looking to copy everything that gets added to one calendar (Cal 1), onto a new and separate one (Cal 2) (which you outline in ) EXCEPT for the content in the body of the appointment itself, (which contains private info not to be shared outside work group).
Also want 'Cal 2' to automatically get assigned a Category (which I will then use to send an email when a reminder fires up ( as you outlined in ). Am I right in trying to combine the two MACROS?
You can certainly change the category of the new appoint created using the code to copy appointments.
Hi Diane,
This is a great resource! I am trying to automate some calendar view settings in Outlook (automatic view rules for appointments - View\Customize Current View\Automatic Formatting) How is this done thru VBA or Powershell?
You can apply a view to a folder using VBA but the ability to create a new view using VBA is limited. Many of the view properties are read-only.
https://msdn.microsoft.com/en-us/library/office/microsoft.office.interop.outlook.calendarview_members.aspx
Hi Diane...thanks for this. I am looking to do something similar in assigning a category to an appointment by setting up a button in the Calendar Tools ribbon. But what I would like it to do is: -
i) assign a category to the appt
ii) set the appt as private
iii) set the appt as free
How could the script above be modified to do that?
Thanks, MA
you need ot add these lines:
appt.BusyStatus = olfree
appt.Sensitivity = olPrivate
appt.categories = "cat1"
Thanks for your prompt reply.
It is for adding categories to mail(s) by using VBA.
The picker is too time consuming when you have many categories to choose from. I therefore plan to have various buttons for my projects.
Happy new year Diane,
Q:How is it done when you want to add > 1 (up to 5) categories to open and/or selected mails at once? Thanks for your feedback.
Using VBA or the Category picker? In the category picker, open the category dialog to to show All categories dialog. For VBA, use: Appt.Categories = "Completed;Something;Another Category;" & Appt.Categories